"Copyright (c) 1989 and 1990, Regents of the University of Washington.
Permission is granted to use or reproduce this program for research
and development purposes only. For information regarding the use of this
program in a commercial product, contact:
Office of Technology Transfer
University of Washington
4225 Roosevelt Way NE, Suite 301
Seattle, WA 98105
ThingLab II was written between 1988 and 1990 by John Maloney and
Bjorn N. Freeman-Benson with the guidance of Alan Borning."!
!Number methodsFor: 'ThingLabII'!
asNonZero
"To avoid divide-by-zero errors, answer a very small number if I am zero."
^(self = 0)
ifTrue: [0.0000000001]
ifFalse: [self]! !
!Symbol methodsFor: 'ThingLabII'!
path
"Answer an array of the part names that comprise the compound path selector. For example, '#fat.cat.hat path' returns an array of three symbols, #fat, #cat, and #hat."
| result currentPart |
result _ OrderedCollection new.
currentPart _ WriteStream on: (String new: 16).
self do:
[: ch |
(ch = $.)
ifTrue:
[result addLast: currentPart contents asSymbol.
currentPart reset]
ifFalse: [currentPart nextPut: ch]].
result addLast: currentPart contents asSymbol.
^result asArray! !
!BitBlt methodsFor: 'ThingLabII'!
drawFrom: p1 to: p2
"This line drawing method was improved by John Maloney to do more intelligent clipping. If the line (p1,p2) is entirely INSIDE the clipping box, this method gives results that are identical to the original line drawing method. If the line is entirely OUTSIDE the clipping box, it detects this early and avoids the cost of drawing it. Finally, if the line is PARTIALLY inside the clipping box, the portion entirely inside the clipping box computed and can be drawn by the primitive. If the pen form is large, you may notice a slight difference from the results given by the normal drawFrom:to: method on the right/bottom of the clipping box."
"The clipping rectangle specified by the sender is intersected with the destination form. Then the corner of the result is inset by the extent of the pen form. This clipping rectangle is used to compute 'clippedLine'. clipped line is a triple <visibleFlag, startPoint, endPoint>. If visibleFlag is false, no part of the line is visible in the clipping box. If visibleFlag is true, clippedLine can be drawn with the primitive, which is fast."
"Answer true if I am a Thing. Normal Smalltalk Objects are not Things."
^false!
traceOwners
"Build the transitive closure of the 'owners' relation. That is, starting with me, add my owners, then my owners' owners, then their owners, and so on until no new objects are added or until we encounter the 'Smalltalk' object, the globals dictionary."
| allOwners allRoots toDo obj owners |
allOwners _ IdentitySet new: 100.
allRoots _ OrderedCollection new.
toDo _ OrderedCollection new.
toDo add: self.
[toDo isEmpty] whileFalse:
[obj _ toDo removeFirst.
owners _ nil.
Smalltalk primGarbageCollect.
owners _ obj allOwners.
owners remove: thisContext ifAbsent: [].
owners remove: allOwners ifAbsent: [].
owners remove: allRoots ifAbsent: [].
owners remove: toDo ifAbsent: [].
owners remove: obj ifAbsent: [].
owners remove: owners ifAbsent: [].
owners _ self filterOwners: owners.
(self includesRoot: owners)
ifTrue: [allRoots add: obj]
ifFalse:
[owners do:
[: owner |
((allOwners includes: owner) or:
[allRoots includes: owner]) ifFalse:
[allOwners add: owner.
toDo add: owner]]].
Transcript show: allOwners size printString; cr].
^Array
with: allOwners asOrderedCollection
with: allRoots!
warning: ignored
"Browsing the senders of this message can be used to find 'soft' spots in the ThingLabII implementation."! !
!ClassDescription methodsFor: 'ThingLabII'!
organization: anOrganizer
organization _ anOrganizer! !
!ScreenController methodsFor: 'ThingLabII'!
announceThingLabII: aForm
"If the given form is not nil, then pop up the ThingLabII intro picture and wait until the user clicks the mouse."
(aForm notNil)
ifTrue: [IntroPicture openOn: aForm].!
openControlPanel
"Pop up the ThingLabII Control Panel."
ThingLabIIControlPanel open.!
openTopBin
"Open a ThingLabII PartsBin view."
PartsBinView openOn: (PartsBin topBin).!
quit
"Save this image and quit from Smalltalk, quit without saving the image, or return to normal operations, depending on the respose of the user to a menu query."
| menu index |
menu _ PopUpMenu
labels:
' Save, then quit
Quit, without saving
Continue '
lines: #(1 2).
index _ menu startUp.
(index = 1)
ifTrue: [self save: true]. "save, then quit"
(index = 2)
ifTrue: [Smalltalk quit]. "quit without saving"
"otherwise, resume normal Smalltalk operations"!
save
"Do a system snapshot but don't quit."
self save: false. "continue after saving"!
save: quitAfterSaving
"Do a system snapshot and quit if 'quitAfterSaving' is true. We pop up the ThingLabII Intro window after saving so it will be the first thing the user see when re-starting the saved image. This means that it also pops up after the save operation. Popping up the ThingLabII Intro window can be disabled by holding down the shift key while performing this operation."
| prefix form |
prefix _ Smalltalk getImagePrefix.
prefix isEmpty ifTrue: [^self].
form _ nil.
sensor leftShiftDown ifFalse:
[(FileDirectory includesKey: 'ThingLabII.form')
ifTrue: [form _ Form readFrom: 'ThingLabII.form']].
"Match myself as a pattern against the target tree and answer true if a match is found. Sometimes I represent a pattern and my variables may match complete subtrees of targetTree. In such cases, the sender supplies an empty Dictionary, matchDict, that is used to map pattern variables to the corresponding subtrees of the target tree. After the match, the dictionary can be used to find which variables matched which subtrees. Sometimes it is desirable to find an exact match, with no variable substitutions. This case is indicated by supplying a 'nil' matchDict. See VariableNode>match:using for further details."
"Move the variable with this key as far left as possible using the message 'swapSides'."
self subclassResponsibility!
removeNodesSurrounding: aVariable
"Repeatedly apply restructuring rules until the given variable has been isolated. If at any point we fail to find a restructuring rule to apply, report and error and give up."
[^self error: 'Can''t reduce the left side because
no rule matches the equation:
', theTree printString].
theTree _ newTree].
^theTree!
restructureForAssigningTo: aVarKey
(self isMemberOf: MessageNode) ifFalse:
[self error: 'Implementation Error: Expected a MessageNode'].
(self allVariables includes: aVarKey) ifFalse:
[self error: 'The equation:
', self printString, '
does not contain the desired variable:
', aVarKey].
^(self moveVariableToFarLeft: aVarKey)
removeNodesSurrounding: aVarKey!
specificMatch: aTree using: matchDict
"Assuming aTree is a ParseNode like me, do a field-by-field comparison between us and answer true if we match. See match:using for further details."
self subclassResponsibility!
swapSides
"Apply the first re-order rule that matches me and return the resulting parse tree. If no rule matches me, return myself."
| dictOrNil |
EquationTranslator reorderRules do:
[: rule |
dictOrNil _ rule matches: self.
(dictOrNil notNil) ifTrue:
[^rule applyUsing: dictOrNil]].
^self! !
!ParseNode methodsFor: 'ThingLabII'!
allVariables
"Answer a set containing all variables used in this parse tree."
| vars |
vars _ IdentitySet new.
self apply:
[: node |
(node isMemberOf: VariableNode)
ifTrue: [vars add: node name asSymbol].
true].
self removePredefinedVarsFrom: vars.
^vars!
assignedTo
"Answer a collection of the variables assigned to in this parse tree."
| vars |
vars _ IdentitySet new.
self apply:
[: node |
(node isMemberOf: AssignmentNode)
ifTrue: [vars add: node variable name asSymbol].
true].
self removePredefinedVarsFrom: vars.
^vars!
referenced
"Answer a collection of the variables that are referenced but not assigned to in this parse tree."
| vars |
vars _ IdentitySet new.
self apply:
[: node |
(node isMemberOf: VariableNode)
ifTrue: [vars add: node name asSymbol. true]
ifFalse:
[(node isMemberOf: AssignmentNode)
ifTrue: [vars addAll: node value referenced. false]
ifFalse: [true]]].
self removePredefinedVarsFrom: vars.
^vars!
removePredefinedVarsFrom: varList
"Remove the pre-defined variable names from the given collection."
#(self super true false nil thisContext) do:
[: predefinedVar |
varList remove: predefinedVar ifAbsent: []].!
transformBy: aBlock
"Answer a copy of the parse tree whose root is me, transformed by the given block. The block takes one argument, some kind of ParseNode, and returns some transformation of the node (or the node itself). For example, the null transformation (which copies the parse tree) is:
aParseTree transformBy: [: node | node]"
self subclassResponsibility! !
!ReturnNode methodsFor: 'ThingLabII'!
apply: aBlock
(aBlock value: self)
ifTrue:
[expr apply: aBlock].!
expr
^expr!
expr: expression
expr _ expression.!
specificMatch: aTree using: matchDict
"See ParseNode>specificMatch:using:"
^expr match: aTree expr using: matchDict!
transformBy: aBlock
| result |
result _ self copy.
result expr: (expr transformBy: aBlock).
^aBlock value: result! !
!SelectorNode methodsFor: 'ThingLabII'!
specificMatch: aTree using: matchDict
"See ParseNode>specificMatch:using:"
^key = aTree key! !
!VariableNode methodsFor: 'ThingLabII'!
mapBy: mappingDict
^mappingDict at: key ifAbsent: [self]!
match: targetTree using: matchDict
"A variable in a pattern may represent an entire subtree. However, if the variable appears multiple times in the pattern then the associated subtree must be the same each time. There are two ways to use the match:using: function: 1.) allowing variables to match arbitrary subtrees or 2.) requiring an exact match (to verify that two subtrees are identical). We indicate the difference by supplying a 'nil' matchDict when we wish to make an exact match."
| binding |
(matchDict isNil)
ifTrue:
["we must have an exact match"
^(targetTree isMemberOf: VariableNode) and:
[name = targetTree name & key = targetTree key]]
ifFalse:
[binding _ matchDict
at: key
ifAbsent:
[matchDict at: key put: targetTree.
^true].
"if we already have a binding for this variable the binding must exactly match the current subtree"
^binding match: targetTree using: nil].!
moveVariableToFarLeft: aVariable
"Move the variable with this key as far left as possible using the message 'swapSides'. This is a noop for variable nodes."
deltaTheta _ (Float pi * 2.0) / vertexCount asFloat.
theta _ Float pi / 2.0.
vertices do:
[: v |
v x: 170 + (70 * theta cos).
v y: 170 + (70 * theta sin).
theta _ theta + deltaTheta].!
setupConstants
"Calculate the spring and length constants for each pair of vertices. Since these are symmetric relations, we need only compute half the matrix; the other half is filled in by symmetry. We assume that the vertices list and transition matrix have already been initialized."
"Layout the connected graph with the given set of vertices and transition matrix. If the graph is not connect, its components should be laid out individually."
vertices _ vertexList.
transitions _ transitionMatrix.
self setupConstants.
self placeVerticesAroundCircle.! !
!GraphLayout methodsFor: 'force-based method'!
computeForces
"Compute the forces vector. The force on each vertex is the vector sum of the component forces of all springs attached to the vertex."
'I represent a walkabout strength equation of the form:
(((constant weakest: a) weakest: b) weakest: c)
where a, b, and c are references to variables whose strength will not be known until run-time. I fold constant terms as I am created.
Strength cooperates with me by turning expressesions of the form:
aStrength weakest: aWalkEquation
into:
aWalkEquation weakest: aStrength
so that I respond with a new WalkEquation.'!
!WalkEquation methodsFor: 'initialize-release'!
constant: aStrength vars: varList
constant _ aStrength.
vars _ varList.! !
!WalkEquation methodsFor: 'access'!
constant
"Answer the constant part of me."
^constant!
vars
"Answer my variable list."
^vars! !
!WalkEquation methodsFor: 'operations'!
sameAs: aStrength
"Answer true if I am constant and I am equal to the given strength."
(constant isNil | vars isEmpty not) ifTrue: [^false].
^constant sameAs: aStrength!
simplify
"Remove redundant 'required' constant. That is, if my constant part is 'required' and my vars list is not empty, the constant part can be omitted since 'required' is the upper bound on constraint strengths anyway."
'This class describes a partition of the constraint graph being debugged. It consists of a collection of DebugConstraintRecords, a constraint solver, and a GraphLayout object for the partition.'!
"Zero is the current solution. Positive integers are alternative possible solutions."
^solutionIndex - 1!
solution: aNumber
"Zero is the current solution. Positive integers are alternative possible solutions."
solutionIndex _ aNumber + 1.
self updateGlyphs.
self setCycleFlag.!
solver
^solver!
solver: aMultiSolver
solver _ aMultiSolver.! !
!DebugPartitionRecord methodsFor: 'operations'!
animateOn: aView
"Animate the placement algorithm."
| layoutTool done |
layoutTool _ self graphLayoutTool.
layoutTool updateVertices.
done _ false.
[done | Sensor anyButtonPressed] whileFalse:
[done _ layoutTool doStep.
self centerConstraints.
aView displaySafe: [aView displayScene]].!
centerConstraints
"Center the constraints of this partition."
| centerOfGraph |
centerOfGraph _
(constraintRecords inject: 0@0 into: [: sum : c | sum + c glyph location]) //
(constraintRecords size).
constraintRecords do:
[: cRec | cRec centerConstraint: centerOfGraph].!
findAllSolutions
"This can be very expensive for large partitions!! Find and record all the possible solutions for this partition so that the user may browse through them."
transitions row: i col: i put: 0]. "zero distance from i to i"
constraintRecords do:
[: cRec |
constraintVars _ cRec varGlyphs.
n _ constraintVars size.
1 to: (n - 1) do:
[: v1 |
i _ (constraintVars at: v1) label.
(v1 + 1) to: n do:
[: v2 |
j _ (constraintVars at: v2) label.
"distance of one between each pair of vertices joined by a constraint"
transitions row: i col: j put: 1.
transitions row: j col: i put: 1]]].
^GraphLayout new vertices: vertices transitions: transitions!
initialLayout
"Construct an initial layout of the graph."
| layoutTool done |
layoutTool _ self graphLayoutTool.
2 timesRepeat: [layoutTool doStep].
self centerConstraints.
neverLaidOut _ false.!
setCycleFlag
"Set the cycleFlag if the current solution has a cycle."
| methodList method |
methodList _ OrderedCollection new: 100.
constraintRecords do:
[: cRec |
method _ cRec solutions at: solutionIndex.
methodList add: method].
cycleFlag _ solver hasCycle: methodList.!
solutionCount
"Answer the number of possible alternate solutions for this partition."
"Detail: The first solution in the solutions list is the current solution, which we don't count."
^constraintRecords first solutions size - 1!
solutionHasCycle
"Answer true if the current solution has a cycle."
^cycleFlag!
toggleLabels
"Toggle the visibility of the constraint labels of this partition."
(constraintRecords first glyph labelIsHidden)
ifTrue: [constraintRecords do: [: c | c glyph showLabel]]
ifFalse: [constraintRecords do: [: c | c glyph hideLabel]].!
updateCurrentSolution
"Update the current solution."
constraintRecords do:
[: cRec | cRec updateCurrentSolution].!
updateGlyphs
"Update the constraint glyphs to reflect the selected solution."
constraintRecords do:
[: cRec | cRec updateGlyph: solutionIndex].! !
Object subclass: #TranslationRule
instanceVariableNames: 'from to '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-Equations'!
TranslationRule comment:
'I am a replacement rule for transforming one parse tree with another. I consists of two parse trees representing patterns, a "from" tree and a "to" tree. The variables in these parse trees represent arbitrary subtrees.
I am used by finding an instance of me whose "from" tree matches the target parse tree. This transformation rule is then "applied" by filling in a copy of its "to" tree with the subtrees of the target parse tree corresponding to the variables of the "from" tree and answering the resulting parse tree.
'!
!TranslationRule methodsFor: 'initialization'!
from: fromString to: toString
"Create parse trees for the expressions represented by my arguments. Verify that the output pattern does not reference any variable that was not part of the input pattern. It is permissible to leave one or more input variables out of the output pattern, although such a transform will naturally lose information."
"check for output vars that were not in the input pattern"
fromVars _ from allVariables.
toVars _ to allVariables.
toVars do:
[: v |
(fromVars includes: v) ifFalse:
[self error: 'Equation Tree Mismatch:
''from'' tree does not contain variable ''', v, '''']].! !
!TranslationRule methodsFor: 'match and apply'!
applyUsing: mappingDict
"Apply this rule by making the variable substitutions given by mappingDict in the output side of the rule. mappingDict was build during matching."
^to transformBy: "transformBy: makes a copy of the tree"
[: node |
(node isMemberOf: VariableNode)
ifTrue: [node mapBy: mappingDict]
ifFalse: [node]]!
matches: targetParseTree
"Match the input pattern of this rule against the given parse tree, collecting mappings from variables to subtrees in a dictionary. If the match succeeds, answer the match dictionary. If it fails, answer nil."
'A ThingPartition is used during module compilation to keep track of the possible solutions for a given partition of the constraint graph. Each partition is eventually compiled into a ModuleConstraint.
id <Integer> unique id for this partition
constraints {Constraint} the constraints for this partition
solutions {{method}} the solutions for this parition
(a solution is a set of methods)
varType <Dictionary> maps each variable (a ThingData) to one of:
"Initialize this instance with the given constraints."
constraints _ constraintList.
id _ nil. "filled in later"
varTable _ nil. "filled in later"
solutions _ nil. "filled in later"! !
!ModulePartition methodsFor: 'operations'!
buildVariableTable
"Build a table of all the variables referenced by my constraints."
"Details: Due to merges, there may be numerous paths (references) for the same variable. The thingData for all refererences will be the same, however, so we use thingDatas to keep track of the variables that have been recorded in the table."
| recordedVars thingData |
varTable _ OrderedCollection new.
recordedVars _ IdentitySet new: 20.
constraints do:
[: c |
(c variables) do:
[: ref |
thingData _ ref thingData.
(recordedVars includes: thingData) ifFalse:
[varTable add: (ModuleVarTableEntry on: ref).
recordedVars add: thingData]]].!
computeSolutions
"Compute all possible solutions to the constraints in this partition."
"Apply the given solution, computing ancestors and walk strengths. The latter quantity is computed symbolically since we don't know the walkabout strengths of the external variables at compile time."
"first, initialize the variables"
varTable do:
[: entry |
(entry isExternal)
ifTrue: [entry thingData initExternal: entry]
ifFalse: [entry thingData initInternal]].
"then, satisfy all constraints using the methods of the given solution"
aSolution methods with: constraints do:
[: method : constraint |
(method isNil)
ifTrue: [constraint whichMethod: nil]
ifFalse:
[constraint satisfyWith: method.
DeltaBluePlanner
addPropagateFrom: constraint
execFlag: false]].!
currentIsPossibleEquation
"Answer the walkabout strength check equation for the current solution."
| walkEqn thingDatas orTerm |
walkEqn _ ModuleConjunction new.
constraints do:
[: c |
(c isSatisfied) ifFalse:
["unsatisfied constraints must not demand satisfaction"
thingDatas _ c thingDatas.
c methods do:
[: m |
orTerm _ ModuleDisjunction new.
m outDatasIn: thingDatas do:
[: v |
orTerm
strength: (c strength)
weakerOrEq: (v walkStrength)].
walkEqn addOrTerm: orTerm]]].
"the propagated walk strengths must be strong enough to override their outputs"
"Record the variable dependencies and walkabout strength equations for all output variables of the current solution. We only record dependencies among the external variables. Also record the status of all variables to help with later classification."
"Answer false if we don't like the currently applied solution. We don't like solutions in which all external variables are outputs having walk strengths of absoluteWeakest."
"Give my internal variables names like 'internal3' starting with the first id following lastId. Answer the last id that I allocated."
| varId |
varId _ lastId.
varTable do:
[: var |
(var isInternal) ifTrue:
[varId _ varId + 1.
var name: 'internal', varId printString]].
^varId!
compileFor: moduleThing
"Compile the isPossible, execute, and propagate methods for each solution of this partition. Add the compiled methods to the class of the given ModuleThing. It is assumed that the class contains instance variables for the external and internal parts."
| externalVars methods prefix newConstraint |
"set up: name variables and collect the external ones"
self nameVars.
externalVars _ varTable select: [: v | v isExternal].
bind: (externalVars collect: [: v | (v reference) root: moduleThing])
strength: #required.
"answer the newly created Module constraint"
^newConstraint!
nameVars
"Name all my non-internal variables for use during compilation. This must be done after variable classification. The internal variables are named separately using allocateInternalVariables:."
!ModulePartition class methodsFor: 'instance creation'!
on: constraintList
"Create a new instance of me on the given collection of constraints."
^self new on: constraintList! !
Collection subclass: #PriorityQueue
instanceVariableNames: 'contents last '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-UI-Layout'!
!PriorityQueue methodsFor: 'public'!
add: newElement
"Insert the given element in the receiver at the proper location."
(contents size == last) ifTrue:
["queue is full, so double the size of 'contents' to make room"
contents _ contents, (Array new: last)].
last _ last + 1.
contents at: last put: newElement.
newElement index: last.
self pushUpFrom: last.!
comment
"The elements of a PriorityQueue must repond to the messages 'index:' and 'index'. The 'index:' message may be a noop but the 'index' message must either answer the last value provided to the element via the 'index:' message or else nil. This behavior is necessary to allow fast relocation of elements when their priorities change."!
do: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument."
| i |
i _ 1.
[i <= last] whileTrue:
[aBlock value: (contents at: i).
i _ i + 1].!
peekMin
"Answer the least element of the receiver without removing it."
(last == 0) ifTrue: [^self errorEmptyCollection].
"The root is the smallest element."
^contents at: 1!
relocate: targetElement
"Find a new position for the given element after it has changed."
"Special add function for support of ShortestPaths. The receiver is first emptied, then all the elements of the given collection except the vertex with the given index are added without regard to order. The elements are given the specified initial cost."
| count i element |
count _ vertexList size.
(contents size < count) ifTrue:
[contents _ Array new: count].
last _ 0.
i _ 1.
[i <= count] whileTrue:
[(i == vertexIndex) ifFalse:
[element _ vertexList at: i.
last _ last + 1.
contents at: last put: element.
element index: last.
element cost: initialCost].
i _ i + 1].!
pushDownFrom: index
"Push the element at index i down through the tree until it is smaller than its children or until it is a leaf with no children."
| leaves parent left right child parentElement childElement |
leaves _ last bitShift: -1.
parent _ index.
[parent <= leaves] whileTrue: "while parent is not a leaf:"
[left _ parent bitShift: 1.
right _ left + 1.
(left == last)
ifTrue:
["left is an only-child"
child _ left]
ifFalse:
["select the smaller child"
((contents at: left) < (contents at: right))
ifTrue: [child _ left]
ifFalse: [child _ right]].
parentElement _ contents at: parent.
childElement _ contents at: child.
(parentElement > childElement)
ifTrue:
["push to next level"
contents at: parent put: childElement.
childElement index: parent.
contents at: child put: parentElement.
parentElement index: child.
parent _ child]
ifFalse:
["parent is smaller than its children; cannot push farther"
^self]].
"pushed all the way to a leaf"
^self!
pushUpFrom: index
"Push the element at the given index up through the tree until it is smaller than its children or until it is the root."
| child parent childElement parentElement |
child _ index.
[(child == 1) ifTrue: [^self]. "child is the root, so it has no parent"
!PriorityQueue class methodsFor: 'instance creation'!
new
"Answer a new instance of me."
^self new: 10!
new: aNumber
"Answer a new instance with the given initial size."
^self basicNew initialize: aNumber! !
StringHolder subclass: #ThingDefiner
instanceVariableNames: 'client view '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-Things-Support'!
!ThingDefiner methodsFor: 'initialize-release'!
client: clientObject
"Register a client object. This client will be updated with the prototype of the newly defined Thing when the user does 'accept'. My initial text is derived from the Thing currently held by the client. The client may be any object the understands the messages #thing and #thing:. If the client object is nil, a new Thing is created but noone is informed."
client _ clientObject.
(client notNil) ifTrue:
[contents _ client thing definitionString].!
view: aView
"Set my view to the given view."
view _ aView.! !
!ThingDefiner methodsFor: 'operation'!
contents: aString
"Define a new Thing based on the text that the user has just 'accepted'. Notify the client, if any, of the new Thing's prototype."
| tree thingName partNames parts nonThingPart type newThing |
tree _ (EquationParser parse: ('dummy ', aString) readStream)
block statements first.
(tree isMemberOf: VariableNode) ifTrue:
[thingName _ tree name asSymbol.
((Smalltalk includesKey: thingName) and:
[(Smalltalk at: thingName) inheritsFrom: Thing])
ifTrue:
[newThing _ (Smalltalk at: thingName) new.
contents _ newThing definitionString.
self changed.
(client notNil) ifTrue:
[client thing: newThing].
^self]
ifFalse:
[^self error: thingName asString, ' is not a Thing']].
thingName _ tree receiver name.
"get partNames and omit trailing colons"
partNames _ tree selector key keywords.
partNames _ partNames collect: [: n | n copyFrom: 1 to: n size - 1].
"get parts"
nonThingPart _ nil.
parts _ tree arguments.
parts _ parts collect:
[: t |
type _ t name asSymbol.
((Smalltalk includesKey: type) and:
[(Smalltalk at: type) inheritsFrom: Thing])
ifTrue: [(Smalltalk at: type) prototype]
ifFalse: [nonThingPart]].
newThing _ Thing
defineNewThingNamed: thingName
withParts: partNames
toHold: parts.
(client notNil) ifTrue:
[client thing: newThing].
(view notNil) ifTrue:
[view model updateCaches.
view displaySafe: [view displayView]].!
open
"Open a view for this ThingDefiner. This call does not return."
!ThingDefiner class methodsFor: 'instance creation'!
open
"Open a new ThingDefiner with no client object or view."
"ThingDefiner open"
(self new)
client: nil;
view: nil;
open!
openOn: clientObject view: aView
"Open a new ThingDefiner for the given client object. The client should understand the messages #thing and #thing:. The view, if non-nil, is updated after the client is changed."
'I am used to record the input/output relationships between external variables for one solution of one partition during the Module compilation process.'!
"Initialize myself with the given values. aVar is dependent on the variables in varList. If stayFlag is true, then the outputs are stay with the given strength. If false, then the output stay flags are must be computed at run time as the logical 'AND' of the input stay flags and the output strengths must be computed by evaluating strength equations."
outVar _ aVar.
dependsOn _ varList asOrderedCollection copy.
stay _ stayFlag.
(stay == true)
ifTrue: [stayStrength _ aStrength]
ifFalse: [stayStrength _ nil]. "stayStrength is undefined if stay is false"!
stay
^stay!
strengthString
"Answer an expression representing the strength at which I am fixed. This operation should only be called if I answer true to the #stay message."
'Strengths are used to measure the relative priority of constraints. The hierarchy of available strengths is determined by the class variable StrengthTable (see my class initialization method). Because Strengths are invariant, references to Strength instances are shared (i.e. all references to "Strength of: #required" point to the same instance). New strengths may be inserted in the strength hierarchy.'!
!Strength methodsFor: 'comparing'!
leq: aStrength
"This is shorthand for 'notStronger: aStrength' (read 'less-than or equal'). This cryptic message is used to make the code for module method 'isPossible' tests more consise and readable. The code given is equivalent to '(self stronger: strength2) not'."
^arithmeticValue >= aStrength arithmeticValue!
notStronger: aStrength
"Answer true if I am the same or weaker than the given Strength. This code is equivalent to:
^(self stronger: aStrength) not"
^arithmeticValue >= aStrength arithmeticValue!
sameAs: aStrength
"Answer true if I am the same strength as the given Strength."
^arithmeticValue = aStrength arithmeticValue!
stronger: aStrength
"Answer true if I am stronger than the given Strength."
^arithmeticValue < aStrength arithmeticValue!
weaker: aStrength
"Answer true if I am weaker than the given Strength."
^arithmeticValue > aStrength arithmeticValue! !
!Strength methodsFor: 'max/min'!
strongest: aStrength
"Answer the stronger of myself and aStrength."
(aStrength class == WalkEquation) ifTrue:
[^aStrength strongest: self].
(aStrength stronger: self)
ifTrue: [^aStrength]
ifFalse: [^self].!
weakest: aStrength
"Answer the weaker of myself and aStrength."
(aStrength class == WalkEquation) ifTrue:
[^aStrength weakest: self].
(aStrength weaker: self)
ifTrue: [^aStrength]
ifFalse: [^self].! !
!Strength methodsFor: 'printing'!
printOn: aStream
"Append a string which represents my strength onto aStream."
'During cloning, the NeedToClone class is used to mark those instance variables in a Thing that have not yet been cloned. For example, a copy of a Thing is made and then some of the instance variables are replaced by doing:
constraints _ (NeedToClone with: constraints).
This indicates that constraints still needs cloning, and that the old value is available as ''constraints data''.
!Partitioner class methodsFor: 'general inquiries'!
partition: aThing
"Partition the constraints of the given Thing. Answer a collection of constraint lists, one for each partition. Each constraint of the given Thing will appear in exactly one of the partitions."
!EquationTranslator class methodsFor: 'class initialization'!
initialize
"This is a simple set of rules for manipulating equations. It has three inherent limitations. First, many of the functions that the Numbers class supports are not one-to-one. The inverse of such functions was chosen arbitrarily. Second, the inverse of some functions is not onto, thus functions like max: are not supported. Finally, rewriting boolean expressions will produce equations that this rewriting system cannot further rewrite."
"EquationTranslator initialize"
ReorderRules _ OrderedCollection new.
RestructureRules _ OrderedCollection new.
self initializeNormalArithmeticRules.
self initializeSpecialArithmeticRules. "these have non-unique inverses"
self initializeUnaryFunctionRules.
self initializeTrigFunctionRules.
self initializeMathematicalFunctionRules.
self initializeSpecialFunctionRules.
self initializeCoercingRules.
"The following rules can be removed if booleans are not needed:"
self initializeTestingRules. "these have non-unique inverses"
self initializeComparingRules. "these have non-unique inverses"
self initializeBooleanFunctionRules.!
initializeBooleanFunctionRules
| tr |
tr _ TranslationRule. "abbreviation"
ReorderRules
add: (tr from: 'a & b' to: 'b & a');
add: (tr from: 'a | b' to: 'b | a');
add: (tr from: 'a xor: b' to: 'b xor: a').
RestructureRules
add: (tr from: 'a not = b' to: 'a = b not');
"add: (tr from: '(a & b) = c' to: 'a = c');" "???"
"add: (tr from: '(a | b) = c' to: 'a = c');" "???"
add: (tr from: '(a xor: b) = c' to: 'a = (b xor: c)').!
initializeCoercingRules
| tr |
tr _ TranslationRule. "abbreviation"
RestructureRules
add: (tr from: 'a asFloat = b' to: 'a = b');
add: (tr from: 'a asInteger = b' to: 'a = b');
add: (tr from: 'a asFraction = b' to: 'a = b').!
initializeComparingRules
| tr |
tr _ TranslationRule. "abbreviation"
RestructureRules
add: (tr from: '(a < b) = c' to: 'a = (c ifTrue: [b - 1] ifFalse: [b])');
add: (tr from: '(a < b) = c' to: 'b = (c ifTrue: [a + 1] ifFalse: [a])');
add: (tr from: '(a <= b) = c' to: 'a = (c ifTrue: [b] ifFalse: [b + 1])');
add: (tr from: '(a <= b) = c' to: 'b = (c ifTrue: [a] ifFalse: [a - 1])');
add: (tr from: '(a = b) = c' to: 'a = (c ifTrue: [b] ifFalse: [b + 1])');
add: (tr from: '(a = b) = c' to: 'b = (c ifTrue: [a] ifFalse: [a + 1])');
add: (tr from: '(a ~= b) = c' to: 'a = (c ifTrue: [b + 1] ifFalse: [b])');
add: (tr from: '(a ~= b) = c' to: 'b = (c ifTrue: [a + 1] ifFalse: [a])');
add: (tr from: '(a > b) = c' to: 'a = (c ifTrue: [b + 1] ifFalse: [b])');
add: (tr from: '(a > b) = c' to: 'b = (c ifTrue: [a - 1] ifFalse: [a])');
add: (tr from: '(a >= b) = c' to: 'a = (c ifTrue: [b] ifFalse: [b - 1])');
add: (tr from: '(a >= b) = c' to: 'b = (c ifTrue: [a] ifFalse: [a + 1])').!
initializeMathematicalFunctionRules
| tr |
tr _ TranslationRule. "abbreviation"
RestructureRules
add: (tr from: 'a exp = b' to: 'a = b ln');
add: (tr from: 'a ln = b' to: 'a = b exp');
add: (tr from: '(a log: b) = c' to: 'a = (b raisedTo: c)');
add: (tr from: '(a log: b) = c' to: 'b = (a raisedTo: c reciprocal)');
add: (tr from: '(a raisedTo: b) = c' to: 'a = (a raisedTo: b reciprocal)');
add: (tr from: '(a raisedTo: b) = c' to: 'b = (c log: a)').!
initializeNormalArithmeticRules
| tr |
tr _ TranslationRule. "abbreviation"
ReorderRules
add: (tr from: 'a = b' to: 'b = a');
add: (tr from: 'a + b' to: 'b + a');
add: (tr from: 'a - b' to: 'b negated + a');
add: (tr from: 'a * b' to: 'b * a').
RestructureRules
add: (tr from: '(a + b) = c' to: 'a = (c - b)');
add: (tr from: '(a - b) = c' to: 'a = (b + c)');
add: (tr from: '(a * b) = c' to: 'a = (c / b)');
add: (tr from: '(a / b) = c' to: 'a = (b * c)');
add: (tr from: '(a / b) = c' to: 'b = (a / c)').!
initializeSpecialArithmeticRules
| tr |
tr _ TranslationRule. "abbreviation"
RestructureRules
add: (tr from: '(a // b) = c' to: 'a = (b * c)');
add: (tr from: '(a // b) = c' to: 'b = (a // c)');
add: (tr from: '(a quo: b) = c' to: 'a = (b * c)');
add: (tr from: '(a quo: b) = c' to: 'b = (a quo: c)');
add: (tr from: '(a rem: b) = c' to: 'a = c');
add: (tr from: '(a rem: b) = c' to: 'b = (a - c)');
add: (tr from: '(a \\ b) = c' to: 'a = c');
add: (tr from: '(a \\ b) = c' to: 'b = (a - c)');
add: (tr from: '(a roundTo: b) = c' to: 'a = c');
add: (tr from: '(a roundTo: b) = c' to: 'b = c');
add: (tr from: '(a truncateTo: b) = c' to: 'a = c');
add: (tr from: '(a truncateTo: b) = c' to: 'b = c').!
initializeSpecialFunctionRules
| tr |
tr _ TranslationRule. "abbreviation"
RestructureRules
add: (tr from: '(a @ b) = c' to: 'a = c x');
add: (tr from: '(a @ b) = c' to: 'b = c y');
add: (tr from: 'a degreesToRadians = b' to: 'a = b radiansToDegrees');
add: (tr from: 'a radiansToDegrees = b' to: 'a = b degreesToRadians');
add: (tr from: 'a asPoint = b' to: 'a = b x').!
initializeTestingRules
| tr |
tr _ TranslationRule. "abbreviation"
RestructureRules
add: (tr from: 'a even = b' to: 'a = (b ifTrue: [0] ifFalse: [1])');
add: (tr from: 'a odd = b' to: 'a = (b ifTrue: [1] ifFalse: [0])');
add: (tr from: 'a negative = b' to: 'a = (b ifTrue: [-1] ifFalse: [0])');
add: (tr from: 'a positive = b' to: 'a = (b ifTrue: [1] ifFalse: [-1])');
add: (tr from: 'a strictlyPositive = b' to: 'a = (b ifTrue: [1] ifFalse: [0])');
add: (tr from: 'a sign = b' to: 'a = b').!
initializeTrigFunctionRules
| tr |
tr _ TranslationRule. "abbreviation"
RestructureRules
add: (tr from: 'a arcCos = b' to: 'a = b cos');
add: (tr from: 'a cos = b' to: 'a = b arcCos');
add: (tr from: 'a arcSin = b' to: 'a = b sin');
add: (tr from: 'a sin = b' to: 'a = b arcSin');
add: (tr from: 'a arcTan = b' to: 'a = b tan');
add: (tr from: 'a tan = b' to: 'a = b arcTan').!
initializeUnaryFunctionRules
| tr |
tr _ TranslationRule. "abbreviation"
RestructureRules
add: (tr from: 'a abs = b abs' to: 'a = b abs');
add: (tr from: 'a abs = b' to: 'a = b abs');
add: (tr from: 'a negated = b negated' to: 'a = b');
add: (tr from: 'a negated = b' to: 'a = b negated');
add: (tr from: 'a reciprocal = b' to: 'a = b reciprocal');
add: (tr from: 'a sqrt = b' to: 'a = b squared');
add: (tr from: 'a squared = b' to: 'a = b sqrt');
add: (tr from: 'a ceiling = b' to: 'a = b');
add: (tr from: 'a floor = b' to: 'a = b');
add: (tr from: 'a rounded = b' to: 'a = b');
add: (tr from: 'a truncated = b' to: 'a = b').! !
!EquationTranslator class methodsFor: 'accessing'!
reorderRules
^ReorderRules!
restructureRules
^RestructureRules! !
!EquationTranslator class methodsFor: 'translating'!
methodsFor: equationString
"Answer an array of assignment statement strings that represent the various inversions of the given equation. For example, the methods for 'a = (b + c)' are 'a _ b + c', 'b _ a - c', and 'c _ a - b'. The top level expression must be an '=' expression. Note that due to Smalltalk's left-to-right evaluation order, the top level expression of 'a = b + c' is the '+' expression, NOT the '=' expression; use parenthesis if necessary."
"Register a client object. This client will be updated with the prototype of the newly defined constraint when the user does 'accept'. My initial text is derived from the constraint currently held by the client. The client may be any object the understands the messages #baseConstraint, #baseConstraint:, #baseStrength, and #baseStrength:."
client _ clientObject.
contents _
clientObject baseStrength, '\' withCRs,
clientObject baseConstraint definitionString.!
view: aView
"Set my view to the given view."
view _ aView.! !
!ConstraintDefiner methodsFor: 'operation'!
buildConstraint: defString methods: methodStrings
| parseTree strength varNames paths full root constraint |
!ConstraintDefiner class methodsFor: 'instance creation'!
openOn: clientObject view: aView
"Open a new ConstraintDefiner for the given client object. The client should understand the messages #baseConstraint, #baseConstraint:, #baseStrength, and #baseStrength:. The view, if non-nil, is updated after the constraint is changed."
(self new)
client: clientObject;
view: aView;
open! !
Object subclass: #ThingData
instanceVariableNames: 'allConstraints determinedBy usedBy walkStrength stay mark '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-Things'!
ThingData comment:
'I store the planner data that must be attached to each constrained part of a Thing. Currently this data is specific to the DeltaBlue algorithm, but it could be extended to support other planners.
Instance variables:
walkStrength... the Walkabout strength of my part <Strength>
stayFlag... true if my part will not change <Boolean>
allConstraints... all the constraints that reference my part {Constraint}
determinedBy... the constraint that currently determines
my part''s value or nil if there isn''t one <Constraint>
usedBy... constraints that currently use my part
as an input {Constraint}
ancestors... references to all the ThingDatas used to compute
my part {ThingData}
'!
!ThingData methodsFor: 'initialize-release'!
destroy
allConstraints _ nil.
determinedBy _ nil.
usedBy _ nil.
walkStrength _ nil.
stay _ nil.
mark _ nil.!
initialize
allConstraints _ Array new.
determinedBy _ nil.
usedBy _ Array new.
walkStrength _ Strength absoluteWeakest.
stay _ true.
mark _ 0.! !
!ThingData methodsFor: 'access'!
addConstraint: aConstraint
"Add the given constraint to the set of constraints that refer to me."
'This class is used to display a Scene. The picture may be scrolled by adjusting ''scrollOffset''. The default controller for SceneView is SceneController.
SceneViews encapsulate the notion of a changing foreground and a fixed background during interactive updates. During an interaction (such as dragging), some glyphs may not change location or appearance. These are part of the "background". All remaining glyphs ("foreground" glyphs) are painted against this unchanging backdrop during the interaction.
Instance Variables:
scrollOffset the current scroll offset of this view
enclosingRect a rectangle large enough to contain all the objects in the scene, plus a small border (this is a cache that must be recomputed when glyphs are moved, added, or removed from the scene)
The following instance variables are only meaningful after ''computeBackground'' has been sent:
backgroundForm a <Form> containing the fixed background
visibleForeground glyphs that are changing but not selected during an interaction
selectedForeground selected glyphs that are changing during an interaction'!
!SceneView methodsFor: 'initialize-release'!
initialize
super initialize.
scrollOffset _ 0@0.
enclosingRect _ nil.! !
!SceneView methodsFor: 'label access'!
newLabel: aString
"Change my label to be the given string."
self topView deEmphasize.
self topView newLabel: aString.
self topView emphasize.! !
!SceneView methodsFor: 'displaying'!
computeBackground
"Compute the backgroundForm and the two lists, visibleForeground and selectedForeground. These are used by the 'displayFeedback' and 'displayFeedbackWithBox:width:' operations."
"Update my display during a user interaction. The client must have called 'computeBackgroundWhileChanging:' to prepare for this operation."
self displayFeedbackWithBox: nil width: nil.!
displayFeedbackWithBox: aRectangle width: w
"Update my display during a user interaction. The client must have called 'computeBackgroundWhileChanging:' to prepare for this operation. If it is not nil, the given rectangle (in model coordinates) is drawn with the given border width as additional feedback."
| viewOrigin clipBox |
viewOrigin _ self viewOrigin.
clipBox _ backgroundForm computeBoundingBox.
backgroundForm displayOn: scratchForm at: 0@0.
visibleForeground do:
[: g | g displayOn: scratchForm at: viewOrigin clippingBox: clipBox].
selectedForeground do:
[: g | g highlightOn: scratchForm at: viewOrigin clippingBox: clipBox].
(aRectangle notNil) ifTrue:
[scratchForm
border: (aRectangle translateBy: viewOrigin)
widthRectangle: (w@w corner: w@w)
mask: (Form black)
clippingBox: clipBox].
scratchForm
displayOn: Display
at: self insetDisplayBox origin + scrollOffset
clippingBox: self insetDisplayBox.!
displayScene
"Display the scene."
self computeBackground.
self displayFeedback.!
displayView
"This method is called by the system when the top view is framed or moved."
"adjust offset in case the view has been resized"
self scrollOffset: scrollOffset.
self displayScene.! !
!SceneView methodsFor: 'controller access'!
defaultControllerClass
^SceneController! !
!SceneView methodsFor: 'scrolling'!
scrollOffset
"Answer my scrolling offset."
^scrollOffset!
scrollOffset: aPoint
"Set my scroll offset after first limiting it to lie within the envelope of permissible values."
"Compute a rectangle capable of enclosing all glyphs in this view. The rectangle's corners are computed and then expanded to allow room for a border. This method should be called any time glyphs are added, removed or moved."
"Parse the given source stream and answer the resulting parse tree. The source stream contents must represent a syntactically correct Smalltalk method definition such as:
foo
a _ b.
c _ 55 * a + b.
That is, there must be a method header followed by a series of statements."
encoder _ EquationEncoder new init: Object context: nil notifying: self.
meth _ self method: false context: nil.
"break cycles & mitigate refct overflow"
failBlock _ parseNode _ nil.
encoder release.
^meth!
parse: sourceStream in: aClass
"Parse the given source stream for the given class and answer the resulting parse tree. The source stream contents must represent a syntactically correct Smalltalk method definition such as:
foo
a _ b.
c _ 55 * a + b.
That is, there must be a method header followed by a series of statements."
encoder _ EquationEncoder new init: aClass context: nil notifying: self.
meth _ self method: false context: nil.
"break cycles & mitigate refct overflow"
failBlock _ parseNode _ nil.
encoder release.
^meth!
parse: sourceStream withEncoder: anEncoder
"Parse the given source stream using the given encoder and answer the resulting parse tree. The source stream contents must represent a syntactically correct Smalltalk method definition such as:
foo
a _ b.
c _ 55 * a + b.
That is, there must be a method header followed by a series of statements."
"Given an initial distance matrix, answer the shortest path cost matrix for the graph. The distance matrix has d(i,j) = 1 if there is a direct path from i to j in the graph, d(i,j) > 1 if there is no direct path from i to j in the graph, and d(i,i) = 0 for all i."
^self new computeDistances: initialDistanceMatrix! !
!ShortestPaths class methodsFor: 'examples'!
example1
"Answers the shortest path matrix for a 3 vertex chain."
"ShortestPaths example1"
^ShortestPaths computeDistances:
((Matrix rows: 3 columns: 3)
fill: 1000;
row: 1 col: 1 put: 0;
row: 2 col: 2 put: 0;
row: 3 col: 3 put: 0;
row: 1 col: 2 put: 1;
row: 2 col: 1 put: 1;
row: 2 col: 3 put: 1;
row: 3 col: 2 put: 1)!
example2: vertexCount
"Answers the time required to compute the shortest paths matrix for an N vertex ring."
"ShortestPaths example2: 80"
"Here are some figures for various values of N using different algorithms:
N = 5, 10, 20, 40, 80, 160
20 92 400 1660 7329 32226 -- dijkstra, final implementation
These figures were collected on a Mac SE with an Irwin 25 MHz accellerator. They provide a glimpse into the complex process of optimizing an algorithm and how effective such optimization can be. 'john' was my original naive solution to problem. Floyd is an implementation of Floyd's algorithm and Dijkstra is an implementation of Dijkstra's algorithm.
Finally, a few tests on the extreme's of Dijkstra's algorithm:
'I embody a simple, non-incremental constraint planning algorithm known as Blue.'!
!BluePlanner methodsFor: 'initialize-release'!
on: aThing
"Initialize myself for satisfying the constraints on the given Thing."
"Note: constraint satisfaction could be done faster if we used one BluePlanner for each constraint partition. The partitions could be maintained incrementally. Food for thought..."
"Figure out how to satisfy the constraints and answer a Plan."
| currentMark constraintCount plan nextC c m |
sortedConstraints do: [: c | c prepareForPlanning].
currentMark _ Time millisecondClockValue.
constraintCount _ sortedConstraints size.
plan _ Plan new: constraintCount * 2.
nextC _ 1.
[nextC <= constraintCount] whileTrue:
[c _ sortedConstraints at: nextC.
m _ c attemptSatisfaction: currentMark.
(m notNil)
ifTrue:
[(c doesSomething) ifTrue: [plan addLast: m].
nextC _ 1]
ifFalse:
[nextC _ nextC + 1]].
^plan! !
Object subclass: #AbstractMethod
instanceVariableNames: 'codeString bindings '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-Constraints'!
AbstractMethod comment:
'A Method is the unit of computation for a constraint. Executing the method enforces the constraint using some the constraint''s variables as inputs and computing other variables as outputs. The input and output variable sets may not intersect but either set may be empty.
Instance variables:
codeString... string that can be used to compile this method <String>
bindings... a string indicating the mapping of constraint variables
to my inputs and outputs. In this string, ''i'' indicates an
input, ''o'' indicates and output, and ''x'' indicates a
constraint variable unused by this method. <String>
inDatas... a cache of the ThingDatas for my inputs {ThingData}
outDatas... a cache of the ThingDatas of my outputs {ThingData}
'!
!AbstractMethod methodsFor: 'access'!
bindings
"Answer my binding array."
^bindings!
bindings: anArrayOfCharacters
"Set my binding array."
bindings _ anArrayOfCharacters.!
codeString
"Answer my code string."
^codeString!
codeString: aString
"Set my code string."
codeString _ aString.! !
!AbstractMethod methodsFor: 'DeltaBlue'!
execute: refList
"Execute myself to enforce my constraint. refList contains all the References for my constraint."
self subclassResponsibility!
inDatasIn: thingDatas do: aBlock
"Evaluate the given block for each of my input ThingDatas."
| i |
i _ bindings size.
[i > 0] whileTrue:
[((bindings at: i) == $i) ifTrue:
[aBlock value: (thingDatas at: i)].
i _ i - 1].!
inputsAreStayIn: thingDatas
"Answer true if all my inputs are stay or if I have no inputs."
| i |
i _ bindings size.
[i > 0] whileTrue:
[((bindings at: i) == $i) ifTrue:
[((thingDatas at: i) stay) ifFalse:
[^false]].
i _ i - 1].
^true!
inputsIn: thingDatas known: currentMark
"Answer true if all my inputs have been determined (i.e. marked with the given mark) or if I have no inputs."
| i |
i _ bindings size.
[i > 0] whileTrue:
[((bindings at: i) == $i) ifTrue:
[((thingDatas at: i) mark == currentMark) ifFalse:
[^false]].
i _ i - 1].
^true!
isPossibleMethodGiven: constraintStrength
"Answer true if I am a possible method given the current walkabout strengths of my variables. Normal (non-Module) methods are always possible."
^true!
outDatasIn: thingDatas do: aBlock
"Evaluate the given block for each of my output ThingDatas."
| i |
i _ bindings size.
[i > 0] whileTrue:
[((bindings at: i) == $o) ifTrue:
[aBlock value: (thingDatas at: i)].
i _ i - 1].!
outputsAreStayIn: thingDatas
"Answer true if all my outputs are stay or if I have no outputs."
| i |
i _ bindings size.
[i > 0] whileTrue:
[((bindings at: i) == $o) ifTrue:
[((thingDatas at: i) stay) ifFalse:
[^false]].
i _ i - 1].
^true!
outputsIn: thingDatas notKnown: currentMark
"Answer true only if none of my outputs have been determined."
"Update the walkabout strengths and stay flags for all my outputs and answer the list of output ThingDatas."
| outs i out thisOut outStrengths |
outs _ #(). "default return value"
i _ bindings size.
[i > 0] whileTrue:
[((bindings at: i) == $o) ifTrue:
[out _ thingDatas at: i.
(thisOut isNil) ifTrue:
[thisOut _ 1. "do this initialization on demand and once at most"
outs _ OrderedCollection new: 10.
outStrengths _ myConstraint strengthsFor: self].
outs add: out.
out walkStrength: (outStrengths at: thisOut).
out stay: stayFlag.
thisOut _ thisOut + 1].
i _ i - 1].
^outs! !
!AbstractMethod methodsFor: 'cloning'!
cloneWith: cloneDictionary for: aConstraint
"Make a clone of myself for the given constraint using the mapping given by cloneDictionary. The default is to NOT copy myself, since non-Module methods can be shared."
First, it is the grouping mechanism for the user-interface.
Second, a Thing is a constrainable object to the planner.
New kinds of Things are created one of three ways:
(A) New empty Things are created by subclassing Thing.
(B) New Things can be created from existing Things by adding and
removing parts.
(C) New Things can be "compiled" from old Things. The old
Thing is then the "construction view" for the new Thing, and
the new Thing is the "use view" for the old.
A Thing must never replace its instance variables (parts), as this could leave dangling references in constraints. Compound parts are updated by recursive copying.
Each kind of Thing is implemented using a normal Smalltalk class and a prototype instance is stored in the class. The prototype is cloned to get new instances of that kind of thing (i.e. this is a prototype based system, rather than a class based one).
When a new part is added to a prototype, its class is updated by adding a named instance variable for the part and by adding access methods to get and change the value of the part. (Detail: Because adding new instance variables to a class is slow, extra instance variables are kept around. These are labeled unused1, unused2, etc.) If there are instances of the class besides the prototype, the class cannot be changed. Instead, a copy of the class and prototype are made and the new class is changed.
Things rely on knowing and controlling their instance variable layout. Please do not subclass a Thing or, if you must, do not add any instance variables or you will get unexpected results.
Instance variables:
parents... the parents of this Thing. There can be
multiple parents because of merging. {Thing}
constraints... the constraints owned by this Thing. Used to
clone constraints along with a Thing. {Constraint}
thingData... data structure for planning (up to one entry per sub-part)
{name->ThingData}
Class instance variables:
thingName... text name given by the user <String>
partIcon... icon for display in the parts bin <Form>
explainText... text description for the user <String>
partNamesAndIndices...
an array of (<Symbol>,<SmallInteger>) pairs
used to keep track of the allocation and naming
of instance variables to hold parts
externalParts... sub-parts to be visible when this Thing is
compiled {Thing}
useView... the class of the useView if this Thing was compiled
prototype... an instance that is the prototype for this type
<some subclass of Thing>
'!
!Thing methodsFor: 'public-part add/remove'!
addPartsNamed: nameList toHold: partsList
"Add a collection of new parts with the given names for the objects in partsList. Compile get and put access methods for the new parts. Answer true if I had to become a new class in order to do this. partsList may contain Strings or Symbols."
| changedType partNameStrings slot |
(self isStructureModifiable) ifFalse:
[^nil error: 'Sorry, my structure cannot be modified'].
"make a new class for me if necessary"
BusyCursor begin.
changedType _ false.
(self isUnencumbered) ifFalse:
[changedType _ true.
self becomeUnencumbered].
"allocate and initialize instance variables"
BusyCursor inc.
partNameStrings _ nameList collect: [: n | n asString].
partNameStrings with: partsList do:
[: partName : part |
BusyCursor inc.
"allocate a new instance variable"
slot _ self findEmptyInstVar.
self class renameInstVarAt: (slot - self class instOffset) as: partName.
self class partNamesAndIndices add: (Array
with: partName asSymbol
with: slot).
"put the new part into the new slot and make me its parent"
self instVarAt: slot put: part.
(part isThing) ifTrue: [part addParent: self]].
"build the part access methods"
BusyCursor inc.
self class
compileAccessMethodsFor: partsList
named: nameList.
BusyCursor end.
^changedType!
addThing: aThing
"Add a part variable with a made up name like 'numberPrinter5' and put aThing into it. This method must handle Thing names that include spaces, digits, and/or capital first letters. Answer true if I had to become a new class to accomplish this."
| partName partNum |
partName _ aThing name asString copyUpTo: $ .
(partName isEmpty) ifTrue: [partName _ 'part'].
partName at: 1 put: (partName at: 1) asLowercase.
[(partName at: partName size) isDigit] whileTrue:
[partName _ partName copyFrom: 1 to: partName size - 1].
(partName isEmpty) ifTrue: [partName _ 'part'].
partNum _ self findEmptyInstVar - self class instOffset.
"nil out the part instance variable and destroy the part"
BusyCursor inc.
partToRemove destroy].
"remove the part's inst var and access methods from the class"
BusyCursor inc.
self instVarAt: instIndex put: nil.
self class removePartNamed: partName asSymbol.
BusyCursor end.
^changedType! !
!Thing methodsFor: 'public-merging'!
extractMergedPart: partRef
"Extract the part with the given reference from the merge it is in. Answer true if I had to create a new class in order to do this. The extracted part retains all internal merges and its internally owned constraints."
| changedType |
"sanity checks"
((partRef topParent == self topParent) and:
[(partRef value isThing) and:
[partRef value parents size > 1]]) ifFalse:
[^self error: 'attempt to unmerge parts that are not merged or that I do not own'].
(self isStructureModifiable) ifFalse:
[^self error: 'you cannot modify the structure of this Thing'].
BusyCursor begin.
changedType _ false.
(self isUnencumbered) ifFalse:
[changedType _ true.
self becomeUnencumbered].
self extractFromMerge: partRef.
BusyCursor end.
^changedType!
extractPart: partRef
"Extract the top-most owner of this part from all merges. For example, if the given reference is for the TextThing part of a NumberPrinter, the NumberPrinter and all its sub-parts will be extracted from all merges."
| changedType topRef |
(self isStructureModifiable) ifFalse:
[^self error: 'Sorry, my structure cannot be modified'].
(parents isEmpty) ifFalse:
[^self error: 'You may only remove top-level parts'].
(partRef value isThing) ifFalse:
[^false]. "can only extract Thing parts"
(partRef topParent ~~ self) ifTrue:
[^self error: 'Part is not owned by me'].
BusyCursor begin.
changedType _ false.
(self isUnencumbered) ifFalse:
[changedType _ true.
self becomeUnencumbered].
"extract the part from all merges"
topRef _ partRef copyFromTopParent.
self isolate: topRef within: topRef.
BusyCursor inc.
BusyCursor end.
^changedType!
mergePart: part1 withPart: part2
"Merge two of my sub-parts. The sub-parts must be Things. Answer true if I had to become unencumbered (i.e. change my class) in order to do the merge."
| changedType |
"sanity checks"
(self isStructureModifiable) ifFalse:
[^self error: 'you cannot modify the structure of this Thing'].
((part1 isThing) & (part2 isThing)) ifFalse:
[self error: 'you may only merge Things'].
((part1 topParent == self topParent) &
(part2 topParent == self topParent)) ifFalse:
[^self error: 'parts may be merged only if they have a common ancestor'].
(part1 == part2) ifTrue:
[^false]. "the given parts are already merged"
BusyCursor begin.
changedType _ false.
(self isUnencumbered) ifFalse:
[changedType _ true.
self becomeUnencumbered].
BusyCursor inc.
(self privateMerge: part1 into: part2) ifFalse:
[Display reverse; reverse].
BusyCursor end.
^changedType! !
!Thing methodsFor: 'public-cloning/destruction'!
clone
"Answer a clone of myself. Cloning Things is done in two passes. In pass 1, we recursively copy the old Thing's part-whole structure, being careful to maintain the same graph structure for shared parts (sharing occurs when parts of the old Thing have been merged). During this first pass we also build a dictionary that maps parts in the old Thing to their corresponding parts in the new Thing. In pass 2, all constraints owned by the old Thing are cloned and and added to the new Thing, after first updating their references to point to the new Thing's parts."
| cloneDictionary myClone constraintsToClone |
cloneDictionary _ IdentityDictionary new: 200.
myClone _ self clonePass1: cloneDictionary.
myClone clonePass2: cloneDictionary.
^myClone!
destroy
"Destroy myself (this instance only, not its class). Destruction helps avoid circular garbage. Warning: be sure not to destroy the prototype for a class of Things unless you know what you are doing."
"Attempt to destroy myself and my class and answer true if successful. In other words, entirely delete all evidence of myself from the system. This can only happen if I am the only instance. This message is sent to the prototype Thing for a class of Things. "
(self class allInstances size == 1) ifFalse: [^false].
self destroy.
self class destroy.
^true! !
!Thing methodsFor: 'public-testing'!
canMerge: thingOne with: thingTwo
"Answer true if I can merge these two parts. The parts can be merged only if they both have the same topParent as me, both are Things of the same class, and they are not already merged."
^(thingOne topParent == self topParent) and:
[(thingTwo topParent == self topParent) and:
[(thingOne isThing & thingTwo isThing) and:
[(thingOne class == thingTwo class) and:
[(thingOne ~~ thingTwo)]]]]!
isStructureModifiable
"Answer true if it is possible to modify my structure, even if doing so entails creating a new class. This is overridden by PrimitiveThing to prevent primitive Things from being modified."
^true!
isThing
"Answer true if I am a Thing."
^true!
isUnencumbered
"Answer true if I am unencumbered and thus can be freely modified. This is true if I am the only instance of my class (i.e. the prototype) and if I have no construction or use views. If I AM encumbered then you can make a new, equivalent, class using the 'becomeUnencumbered' message, and modify the prototype of the new class."
^(self class allInstances size = 1) and:
[(self class useView isNil) and:
[self class constructionView isNil]]!
isUseView
"Answer true if I was compiled from another Thing."
^self class constructionView notNil! !
!Thing methodsFor: 'public-references'!
-> aPathSymbol
"Answer a Reference to the part of me with the given path. The path is a possibly compound symbol such as '#a.node.lastValue'."
^Reference on: self path: aPathSymbol asSymbol path!
partAt: aPath
| part |
part _ self.
aPath path do:
[: partName |
part _ part perform: partName].
^part!
referenceToYourself
"Answer a Reference to myself."
| aParent |
aParent _ parents first.
^aParent->(aParent firstPartNameFor: self)! !
!Thing methodsFor: 'public-stay constraints'!
defaultStay: path
"Add a default stay constraint to the given part of me. Answer the constraint."
^self addConstraint:
(StayConstraint
ref: self->path
strength: #default)!
preferStay: path
"Add a preferred stay constraint to the given part of me. Answer the constraint."
^self addConstraint:
(StayConstraint
ref: self->path
strength: #preferred)!
requireStay: path
"Add a preferred stay constraint to the given part of me. Answer the constraint."
^self addConstraint:
(StayConstraint
ref: self->path
strength: #required)!
strongDefaultStay: path
"Add a default stay constraint to the given part of me. Answer the constraint."
^self addConstraint:
(StayConstraint
ref: self->path
strength: #strongDefault)!
stronglyPreferStay: path
"Add a strongly preferred stay constraint to the given part of me. Answer the constraint."
^self addConstraint:
(StayConstraint
ref: self->path
strength: #strongPreferred)!
weakDefaultStay: path
"Add a weak default stay constraint to the given part of me. Answer the constraint."
^self addConstraint:
(StayConstraint
ref: self->path
strength: #weakDefault)! !
!Thing methodsFor: 'public-equals constraints'!
default: pathOne equals: pathTwo
"Add and answer a default equality constraint between the given parts of me."
^self addConstraint:
(EqualityConstraint
ref: self->pathOne
ref: self->pathTwo
strength: #default)!
prefer: pathOne equals: pathTwo
"Add and answer a preferred equality constraint between the given parts of me."
^self addConstraint:
(EqualityConstraint
ref: self->pathOne
ref: self->pathTwo
strength: #preferred)!
require: pathOne equals: pathTwo
"Add and answer a required equality constraint between the given parts of me."
^self addConstraint:
(EqualityConstraint
ref: self->pathOne
ref: self->pathTwo
strength: #required)!
stronglyPrefer: pathOne equals: pathTwo
"Add and answer a strongly preferred equality constraint between the given parts of me."
"Create and add a constraint of the given strength constructed from the given set of methods. Answer the constraint constructed. See require:where: for a description of the bindingList."
"Add an offset constraint to make the part with pathTwo be equal to the part with pathOne plus the given offset."
^self addConstraint:
(OffsetConstraint
ref: self->pathTwo
ref: self->pathOne
strength: aSymbol
offset: offset)!
prefer: anEquation where: bindingsList
"Create and add a preferred constraint constructed from the given equation (a String). Answer the constraint constructed. See require:where: for a description of the bindingList argument."
"Create and add a required constraint constructed from the given equation (a String). Answer the constraint constructed. bindingsList is an ordered list of (variableName, part) pairs such as #((x1 a.location.x) (x2 b.location.x)). In each pair, variableName is a variable in the equation and part is a path for the part of me to which the variable should be bound."
"Create and add a strongly preferred constraint constructed from the given equation (a String). Answer the constraint constructed. See require:where: for a description of the bindingList argument."
"If this thing keeps previous states, then tick its 'clock' to advance the states one step. Things that don't keep history do nothing."!
keepsHistory
"Some Things keep one or more previous states of some of their variables. Such Things should answer true to this message and should also implement the 'advanceHistory' message."
"Many primitive Things obey the basic protocol for glyphs. That is, they may be displayed, selected, and moved. A Thing often makes all the glyphs of its component parts available for all these operations. However, sometimes a Thing may hide some of the glyphs of its components or some aspect of those glyphs, such as the ability to select them. Thus, there are different messages for collecting the glyphs of Thing for various purposes. A Thing may override the default behavior (which is to return all the glyphs of its sub-parts) to control the visibility of its sub-part's glyphs for different operations. The three categories of glyphs are:
1. visible glyphs -- glyphs that are visible in the display
2. selectable glyphs -- glyphs that can be selected and moved
3. input glyphs -- glyphs that respond to keyboard and/or mouse events
These categories are orthogonal, so it is possible to have visible glyphs that cannot be selected and moved or glyphs that can be selected but are not visible (such as the end points of a PlainLine). One could extend this set of classes if necessary; these are just the categories that have been useful so far.
Note: If a Thing is visible, it must respond to glyph protocol. If a Thing is selectable, it must also respond to the 'location' message. If a Thing is an input glyph, it must also respond to the 'wantsKeystrokes' and 'wantsMouse' messages, and if it answers 'true' to one of these messages, it must support the corresponding keyboard or mouse prototcol."!
inputGlyphs
"Answer the set of my glyphs that are candidates for mouse and/or keyboard input."
| inputGlyphs |
inputGlyphs _ OrderedCollection new.
self inputGlyphsInto: inputGlyphs.
^self removeDuplicates: inputGlyphs!
inputGlyphsInto: aSet
"Add all my possible input Thing parts to aSet."
self thingPartsDo:
[: p | p inputGlyphsInto: aSet].!
removeDuplicates: aCollection
"Answer a copy of the given collection without duplicates. The order of the collection is maintained."
| result |
result _ aCollection species new: aCollection size.
"This is the generic Thing display method. Subclasses of Thing may implement more specialized display methods. This method displays all the parts of the Thing."
self thingPartsDo:
[: part |
part
displayOn: aDisplayMedium
at: aDisplayPoint
clippingBox: clipBox].!
glyphDependsOn
"Answer a collection of Things whose values affect my display appearance (i.e. my glyph). By default, my display appearance does not depend on anything."
"Answer a PointThing that is my location. This must be implemented by any Thing that may be a selectable glyph."
self subclassResponsibility! !
!Thing methodsFor: 'UI-keyboard'!
handleKeystroke: aCharacter view: aView
"Accept the given character. The default behavior is to do nothing."!
keystrokeConstraints
"Answer a list of constraints that should be added before I accept keyboard input."
^self subclassResponsibility!
wantsKeystrokes
"Answer true if I want to get keyboard input. Subclasses may refine this method."
^false! !
!Thing methodsFor: 'UI-mouse'!
handleMouseDown: mousePoint view: aView
"The mouse button has been pressed. mousePoint is in local coordinates. The default behavior is to do nothing."!
handleMouseMove: mousePoint view: aView
"The message is sent repeatedly while the mouse button is pressed. mousePoint is in local coordinates. The default behavior is to do nothing."!
handleMouseUp: mousePoint view: aView
"The mouse button has gone up. mousePoint is in local coordinates. The default behavior is to do nothing."!
mouseComment
"Mouse event handling: When mouse input is initiated (with option-mouse button), the following sequence of events occurs:
1. mouseConstraints is sent to the Thing to get a list of constraints to be added before processing mouse events. The constraints are added and, if they can all be satisfied, processing proceeds. If any of these constraints cannot be satisfied, all the constraints are removed and mouse input is aborted.
2. handleMouseDown:view: is sent to the Thing (exactly once)
3. handleMouseMove:view: is sent to the Thing repeatedly while the mouse is down (at least once)
4. handleMouseUp:view: is sent to the Thing (exactly once)
5. the constraints are removed.
All of the handleMouseXXX: messages have an argument which is the mouse position in Thing coordinates."!
mouseConstraints
"Answer a list of constraints that should be added before processing mouse events."
^self subclassResponsibility!
wantsMouse
"Answer true if I want to be informed of mouse activity. The default behavior is to answer false."
^false! !
!Thing methodsFor: 'initialize-merge'!
initialize
"Initialize my Thing-related fields."
parents _ Array new.
constraints _ Array new.
thingDatas _ Dictionary new.!
merge: pathOne with: pathTwo
"Merge the two sub-parts of me with the given paths."
"WARNING: This is meant only for use in initializing new PrimitiveThings, so sanity checks are skipped."
"Details: The instance variable 'parents' is an array of Things. Due to merges, a Thing may have several parents. Each parent appears only once in the parents array (since we do not allow merges between the immediate children of a Thing, it should never be requested to have the same parent appear more than once anyhow)."
(parents includes: aThing) ifFalse:
[parents _ parents copyWith: aThing].!
allPartNamesFor: anObject
"Answer all the parts names for the given object in this Thing. (Due to merges, there may be more than one). Raise an error if anObject is not one of my parts."
| names |
names _ OrderedCollection new: 10.
self partsAndNamesDo:
[: part : name |
(part == anObject) ifTrue: [names add: name]].
(names isEmpty) ifTrue:
[^self error:
'ThingLab Internal Error: the given object is not one of my parts'].
^names!
allTopParentPaths
"Answer a collection of all paths from my top-most parent to me. A path is an OrderedCollection of Symbols. If I have no parents, answer a collection containing one path, the empty path."
| allPaths pathsToParent thisPath |
(parents isEmpty) ifTrue: "no parents, so answer includes just the empty path"
"Remove the ThingData for this part of me if and only if it is no longer used by any constraint. This is complicated if the part is merged because there may be pointers to its ThingData in the thingData Dictionaries of its other parents."
"Answer the ThingData entry for this part of me from my local dictionary or nil if there isn't one."
^thingDatas at: partSymbol ifAbsent: [nil]!
strengthFor: partName
"Answer the walkabout strength for this part of me. If there is no thingData for the given part, answer (Strength absoluteWeakest)."
| thingData |
thingData _ self thingDataFor: partName.
(thingData isNil)
ifTrue: [^Strength absoluteWeakest]
ifFalse: [^thingData walkStrength].!
thingDataFor: partName
"Answer the ThingData for this part of me. If there isn't one locally, look for one among the part's other parents, in case the part participates in a merge. If we find one, make a local pointer to it for faster access in the future."
| partSymbol part thingData |
partSymbol _ partName asSymbol.
"look for a ThingData locally and answer it if we find one"
thingData _ self localThingDataFor: partSymbol.
(thingData notNil) ifTrue: [^thingData].
"if the part isn't a Thing then I am its only parent (only Things can be merged) so it has no ThingData"
part _ self perform: partSymbol.
(part isThing) ifFalse: [^nil]. "no ThingData found"
"otherwise, look for a thingData in some other parent of the (Thing) part"
"Answer the ThingData structure for this part of me. If there isn't one locally, search among all the part's immediate parents to find one. If we find one, make a local pointer to it. If we don't find one, allocate a new ThingData locally."
| thingData |
thingData _ self thingDataFor: partName.
"if we there is currently no ThingData for this part, allocate one"
(thingData isNil) ifTrue:
[thingData _ ThingData new].
"store a pointer to the thingData locally and answer it"
thingDatas at: partName asSymbol put: thingData.
^thingData!
thingDatas
"Answer my ThingData dictionary. The entries of this dictionary map the part names (Symbols) of my constrained parts to ThingData objects."
^thingDatas! !
!Thing methodsFor: 'constraints'!
addConstraint: aConstraint
"Add the given constraint to the set of constraints that I own and satisfy it. Answer the constraint."
constraints _ constraints copyWith: aConstraint.
aConstraint addConstraint.
^aConstraint!
constraints
"Answer the set of constraints that I own."
^constraints!
constraints: newConstraints
constraints _ newConstraints.!
removeConstraint: aConstraint
"Remove the given constraint from the data flow and from the set of constraints that I own."
"Evaluate aBlock on me and each of my Thing subparts, recursively."
self thingPartsDo: [: p | p allThingsDo: aBlock].
aBlock value: self.!
partIndicesDo: aBlock
"Do aBlock for each of my part variable indices."
self class partNamesAndIndices do:
[: nameAndIndex |
aBlock value: (nameAndIndex at: 2)].!
partsAndNamesDo: aBlock
"Do aBlock for each of my parts and its name."
| name part |
self class partNamesAndIndices do:
[: nameAndIndex |
name _ (nameAndIndex at: 1).
part _ self instVarAt: (nameAndIndex at: 2).
aBlock value: part value: name].!
thingPartsAndNamesDo: aBlock
"Do aBlock for each of my Thing parts and its name."
| name part |
self class partNamesAndIndices do:
[: nameAndIndex |
name _ (nameAndIndex at: 1).
part _ self instVarAt: (nameAndIndex at: 2).
(part isThing) ifTrue: [aBlock value: part value: name]].!
thingPartsDo: aBlock
"Do aBlock for each of my Thing parts."
| part |
self class partNamesAndIndices do:
[: nameAndIndex |
part _ self instVarAt: (nameAndIndex at: 2).
(part isThing) ifTrue: [aBlock value: part]].! !
!Thing methodsFor: 'modification'!
allocateNewInstVars
"Allocate a gaggle of new instance variables for my class. The variables will be given names such as 'unused13'."
| oldInstVarCount increment newVars |
oldInstVarCount _ self class instVarNames size.
increment _ oldInstVarCount min: 64.
newVars _ ''.
oldInstVarCount + 1 to: oldInstVarCount + increment do:
[: i | newVars _ newVars, 'unused' , i printString, ' '].
"By luck it turns out that the addInstVarName: message works with a string containing multiple instance variables."
self class addInstVarName: newVars.!
becomeUnencumbered
"This method clones the class of this Thing to create an identical, but unused, class and prototype. This is used when we wish to modify classes that have existing instances. NOTE: The class of the receiver of this message changes as a side effect!!"
| newName newThingClass cloneDict myClone newPrototype part |
"sanity checks"
(parents size == 0) ifFalse:
[^self error: 'ThingLab Internal Error --
this Thing is supposed to be a prototype;
it should not have parents'].
"make a copy of my class, give it a new class name and a new parts bin name, and classify it in the Smalltalk system dictionary."
newName _ self class successorName asSymbol.
(Smalltalk includesKey: newName) ifTrue:
[^self error: 'The class name ''', newName, ''' is already used.'].
newThingClass _ self class copy.
newThingClass organization: self class organization deepCopy.
newThingClass smashName: newName.
Smalltalk at: newName put: newThingClass.
SystemOrganization
classify: newName
under: 'Things-Built' asSymbol.
newThingClass initializeByCopying: self class.
"create a prototype instance for the new class, and then make a copy of myself to become the prototype for the new class. This is a four step process:
1. create an instance of the new class
2. clone my structure and values (using clonePass1:)
3. copy the clone's variables to the instance (thus making it the equivalent of my clone but having the new class)
4. clone my constraints to the class instance (using clonePass2:)"
"clone my structure and values"
cloneDict _ IdentityDictionary new: 200.
myClone _ self clonePass1: cloneDict.
"make a thing of the new class and copy the clone's top parts into it"
newPrototype _ newThingClass basicNew initialize.
1 to: self class instSize do: [: index |
part _ myClone instVarAt: index.
newPrototype instVarAt: index put: part.
(part isThing) ifTrue:
["I will the parent after the 'become:' coming up"
cloneDict at: self put: self. "this is because of the 'become:' coming up"
newPrototype clonePass2: cloneDict.
"fix up the prototypes for life after the 'become:'"
newThingClass prototype: self.
self class prototype: newPrototype.
"finally, I become the new prototype, and he becomes me"
self become: newPrototype.!
findEmptyInstVar
"Answer the index of an unused instance variable in my class. Use one of the pre-allocated instance variables if possible, otherwise allocate some more and try again."
| partsSet allInstVars |
partsSet _ Set new: 40.
self class partNamesAndIndices do:
[: entry | partsSet add: entry first asString].
allInstVars _ self class instVarNames.
1 to: allInstVars size do:
[: i |
(partsSet includes: (allInstVars at: i))
ifFalse: [^i + self class instOffset]]. "found a free inst var"
"allocate some new instance variables and try again"
self allocateNewInstVars.
^self findEmptyInstVar! !
!Thing methodsFor: 'cloning'!
clonePass1: cloneDictionary
"Recursively clone myself and each of my parts, recording all clones in the given clone dictionary. If I am already in the clone dictionary, then answer a pointer to my clone, rather than copying myself again; this will preserve the acyclic structure of the sub-part graph. This operation copies the part-whole structure of a Thing and establishes its parent pointers but it does not copy the constraints or ThingData dictionaries."
"Clone my constraints. This method executes in the context of the newly forming clone. Because there may be multiple paths to a part and we don't wish to clone a set of constraints multiple times, the NeedToClone class is used to mark constraints that have not yet been cloned. If we encounter a part who's constraints instance variable is not marked with a 'NeedToClone' then we need not look at its sub-parts."
| newC |
(constraints isMemberOf: NeedToClone) ifTrue:
[constraints _ constraints data collect:
[: c |
newC _ c cloneUsing: cloneDictionary.
newC addConstraint.
newC].
self thingPartsDo: [: p | p clonePass2: cloneDictionary]].! !
!Thing methodsFor: 'merging'!
change: thingOne to: thingTwo
"Replace all my references to thingOne with references to thingTwo."
self partIndicesDo:
[: i |
((self instVarAt: i) == thingOne) ifTrue:
[self instVarAt: i put: thingTwo]].!
conflictsBetween: partOne and: partTwo
"We intend to merge the given parts. Look for required-constraint conflicts between the parts themselves and all the corresponding parts of their sub-part trees and answer true if a conflict is discovered. The parts are assumed to be Things of the same class."
"NOTE: We do NOT check for potential cycle conflicts."
^allConstraints select: [: c | (ownedConstraints includes: c) not]!
privateMerge: partOne into: partTwo
"Merge partOne with partTwo and answer true if the operation succeeds. The parts must share a common ancestor. After the merge, partOne will be discarded."
"Here is an outline the merge operation:
1. A check is made of all thingDatas for corresponding pairs
of sub-parts to be sure that no required constraint conflicts
would be caused by the merge.
2. Constraints external (i.e. not owned by any sub-part)
to both part trees are collected and temporarily removed.
3. The pointers to partOne in its parent are pointed to partTwo.
4. The parents of partOne are added to partTwo.
5. partOne is destroyed (but not its subparts, which may still be in use!!)
6. The constraints collected in step 2 are re-added."
"protect subparts from destruction; they may still be in use"
partOne partIndicesDo: [: i | partOne instVarAt: i put: nil].
partOne destroy.
"step 6"
removedConstraints do:
[: constraint | constraint addConstraint].
"merging was successful"
^true!
subPartConflictsBetween: thingOne and: thingTwo
"Check for required-constraint conflicts between the corresponding sub-parts of thingOne and thingTwo and answer true if a conflict is discovered. thingOne and thingTwo are assumed to be Things of the same class."
"The part pointed to by thingRef will be extracted from the merge that it is in. This method only unmerges at the level of thingRef; it does not unmerge merged sub-parts."
"Details: When unmerging, we must separate the constraints attached to what used to be the single, merged part. After the unmerge, some of these constraints will continue to point to the old part, some will point to the new part, and some will point to both parts. This process is implemented by removing all the constraints that touch the merged part and reinstating them after the unmerge. Because the constraints have built-in references, they will be reinstated in their correct locations."
"remove all constraints for the merge and remember them"
removedConstraints _
parent removeConstraintsForPart: thingRef part.
"clone a copy of the old part to become the new part"
"(the clone will get copies of all constraints owned by the part)"
BusyCursor inc.
newPart _ oldPart clone.
"insert newPart into its parent and fix the parents of both parts"
BusyCursor inc.
parent change: oldPart to: newPart.
oldPart removeParent: parent.
newPart addParent: parent.
"reinstate the constraints"
removedConstraints do:
[: c |
BusyCursor inc.
c addConstraint].!
isolate: thingRef within: rootRef
"Isolate the sub-parts tree for the Thing pointed to by thingRef from all merges external to rootRef. Used when removing a part that might be merged with some other parts."
| top thing internalRef externalRef |
thingRef refresh.
top _ thingRef topParent.
thing _ thingRef value.
"look for an external reference to me"
externalRef _ nil.
(thing allTopParentPaths) do:
[: path |
(rootRef isPrefixOf: path) ifFalse:
[externalRef _ (Reference on: top path: path)]].
"if there was an external reference then, extract myself from the merge"
(externalRef notNil) ifTrue:
[self extractFromMerge: thingRef].
"do the same for my sub-parts"
thing thingPartsAndNamesDo:
[: part : partName |
self
isolate: (thingRef, (Array with: partName))
within: rootRef].!
removeConstraintsForPart: partName
"Remove all constraints for the part of me with the given name and all its sub-parts and add the removed constraints to the given set."
| allConstraints thingData part |
allConstraints _ IdentitySet new.
"collect top-level constraints"
thingData _ self thingDataFor: partName.
(thingData notNil) ifTrue:
[allConstraints addAll: thingData constraints].
"collect sub-part constraints"
part _ self perform: partName asSymbol.
(part isThing) ifTrue:
[part allThingsDo:
[: subPart |
subPart thingDatas do:
[: thingData |
allConstraints addAll: thingData constraints]]].
"remove the collected constraints"
allConstraints do:
[: c |
BusyCursor inc.
c removeConstraint].
^allConstraints! !
!Thing methodsFor: 'printing'!
definitionString
"Answer a string containing my definition for the Thing definer."
"Create a new subclass of Thing for a new type of Thing with the given parts. Give the new Thing the given name. Answer the prototype instance of the new Thing's class."
"Answer a copy of my prototype to be used as a sub-part of aThing (i.e. aThing will be made a parent of the copy). This method is 'syntactic sugar' for building the structure of primitive Things."
^(self prototype clone) addParent: aThing!
new
"Answer a copy of my prototype."
^self prototype clone! !
!Thing class methodsFor: 'access'!
basicPrototype
"Answer the contents of my prototype field. Do not create a new prototype."
^prototype!
constructionView
"Answer the class of the Thing that was compiled to create me. Non-module Things have no construction view, so answer nil. This method is overridden in ModuleThing class."
^nil!
constructionView: aThingClass
"Set the class of the Thing that was compiled to create me."
self subclassResponsibility!
explainText
"Answer my explanation."
^explainText!
explainText: aString
"Set my explanation."
explainText _ aString.!
externalParts
"Answer my set of external parts."
^externalParts!
externalParts: collectionOfPartNames
"Set my set of external parts. These are the parts that will be visible to the outside world after compiling me into a module."
externalParts _ collectionOfPartNames.!
partIcon
"Answer my part icon for the parts bin."
^partIcon!
partIcon: aForm
"Set my part icon for the parts bin."
partIcon _ aForm.!
prototype
"Answer my prototype. This is the actual prototype, NOT a copy."
"This is the number of internal (i.e. non-part) instance variables every Thing has. This offset must be added to change local inst var indices into indices for the object as a whole."
^3!
partNamesAndIndices
"Answer a collection of (name, instVarIndex) pairs for my parts."
^partNamesAndIndices!
removeInstVarNamed: nameString
"Rename the instance the the given part to 'unusedNNN'."
| instVars |
instVars _ self instVarNames.
1 to: instVars size do:
[: i |
(nameString = (instVars at: i)) ifTrue:
[^self
renameInstVarAt: i
as: 'unused', i printString]].
self error: 'ThingLabII Internal Error -- could not find instVar with given name'.!
removePartNamed: partSymbol
"Remove the part with the given name and its access methods."
"remove the part as an instance variable and also remove its records in partNamesAndIndices and externalParts"
"Compile access methods for the given parts. The two arguments should be sequenceable collections of the same size. thingsOrObjects are prototypes for the parts (either Things or normal Smalltalk objects) and partNames are the names for these parts."
"Compile the put method for the part with the given name. The part is assumed to contain a normal Smalltalk object, not a Thing. The method will take the form:
"Compile the put method for the part with the given name. The part is assumed to contain a Thing like the given example. The method will take the form:
primXXX: arg
XXX primYY: arg YY.
XXX primZZ: arg ZZ"
| selector arg rcvr statements s m1 block methodNode |
'I embody the DeltaBlue algorithm given in "The DeltaBlue Algorithm: An Incremental Constraint Hierarchy Solver" by Bjorn N. Freeman-Benson and John Maloney.
"Extract a plan for the constraints on the given set of changing (i.e. non-stay) thingDatas. If optimizeStays is true, it is assumed that all variables marked 'stay' were computed as the constraints were added. Since these variables will not change, they (and any variables upstream of them) will not be recomputed by the plan. If optimizeStays is false, all variables will be recomputed by the plan."
"Two pass implementation:
1. Build a plan potentially containing redundant constraints. Clear
marks on all constraints as they are added to the plan.
2. Filter out duplicate constraints by using marks."
"Extract the current solution for the given Thing's constraints as a Plan."
"Details: There are two ways to extract a dataflow from the current DeltaBlue plan: top-down and bottom-up. Bottom-up starts with the terminal nodes and works 'upstream' in the dataflow graph. Top-down starts at all the source nodes and works down. This method implements bottom-up."
"Extract a plan for the constraints on the given set of thingDatas. If optimizeStays is true, it is assumed that all variables marked 'stay' were computed as the constraints were added. Since these variables will not change, they (and any variables upstream of them) will not be recomputed by the plan. If optimizeStays is false, all variables will be recomputed by the plan."
| hotConstraints plan hotC |
currentMark _ Time millisecondClockValue.
hotConstraints _ OrderedCollection new: 200.
plan _ Plan new: 100.
thingDatas do:
[: thingData |
(thingData constraints size > 0) ifTrue:
[(thingData determinedBy isNil) ifTrue:
[thingData mark: currentMark].
thingData constraints do:
[: c |
(c isSatisfied)
ifTrue: [c clearCommitted]
ifFalse: [c setCommitted].
((c isSatisfied) and:
[c inputsKnown: currentMark]) ifTrue:
[hotConstraints addFirst: c]]]].
[hotConstraints isEmpty] whileFalse:
[hotC _ hotConstraints removeFirst.
((hotC isCommitted not) and:
[hotC inputsKnown: currentMark]) ifTrue:
[(hotC shouldUseGiven: optimizeStays) ifTrue:
[plan addLast: hotC].
hotC setCommitted.
hotC outDatasDo:
[: out |
out mark: currentMark.
out usedBy do:
[: c |
(c isCommitted) ifFalse:
[hotConstraints addLast: c]]]]].
^plan! !
!DeltaBluePlanner class methodsFor: 'value propagation'!
propagateFrom: aThingData
"The variable associated with the given ThingData has changed. Propagate new values downstream."
| todo |
(aThingData isNil) ifTrue: [^self]. "no constraints since ThingData is nil"
todo _ OrderedCollection new: 100.
todo add: aThingData.
[todo isEmpty] whileFalse:
[(todo removeFirst usedBy) do:
[: constraint |
constraint execute.
constraint whichMethod
outDatasIn: constraint thingDatas
do: [: out | todo add: out]]].! !
!DeltaBluePlanner class methodsFor: 'private'!
addPropagateFrom: aConstraint execFlag: execFlag
"Recompute the walkabout strengths and stay flags of all variables downstream of the given constraint. If execFlag is true, also recompute the actual values of all downstream variables whose stay flag is true. If the propagation succeeds without finding a cycle, answer true. If a cycle is detected, undo the propagation and answer false."
| bindings thingDatas refs outs savedDBData i out cycleFound entry varIndex |
"save output variable state to allow restoring"
bindings _ aConstraint whichMethod bindings.
thingDatas _ aConstraint thingDatas.
refs _ aConstraint variables.
outs _ OrderedCollection new: 12.
savedDBData _ OrderedCollection new: 12.
i _ bindings size.
[i > 0] whileTrue:
[((bindings at: i) == $o) ifTrue:
[out _ thingDatas at: i.
outs add: out.
savedDBData add:
(Array
with: i
with: ((refs at: i) value)
with: out stay
with: out walkStrength)].
i _ i - 1].
"calculate and propagate new values"
aConstraint calculateDeltaBlueData: execFlag.
cycleFound _ self
propagateFrom: outs
watchFor: (aConstraint inDatas)
execFlag: execFlag.
"cycle found: must restore all values to their previous states"
"Attempt to add the given constraint. If successful, resatisfy any overridden constraints. The markValue is not reset to avoid getting into an infinite loop alternately satisfying and unsatisfying a cycle of constaints."
"Take note of variables to propagate from. If this is part of a retract operation, we propagate only from the unmarked (downstream) outputs. Otherwise, we propagate from all outputs."
outVars _ OrderedCollection new: 12.
aConstraint outDatasDo:
[: out |
unmarkedFlag
ifTrue:
[(out mark ~~ currentMark) ifTrue:
[outVars add: out]]
ifFalse:
[outVars add: out]].
"If this is a retract operation, choose a temporary mark, remembering the old one."
unmarkedFlag ifTrue:
[oldMark _ currentMark.
self chooseNewMark].
"NOTE: unsatisfy sets whichMethod to nil"
aConstraint unsatisfy.
"propagate DeltaBlue data and collect the affected constraints, sorted in order of decreasing strength"
hotConstraints _ (SortedCollection new: 200)
sortBlock: [: i : j | i isStrongerThan: j].
multiOutConstraints _ OrderedCollection new: 100.
self
removePropagateFrom: outVars
unsatisfiedInto: hotConstraints
multiOutsInto: multiOutConstraints.
"consider currently unsatisfied constraints for possible resatisfaction (except the one we are removing!!)"
hotConstraints do:
[: c |
(c ~~ aConstraint) ifTrue:
[self incrementalAdd: c]].
"re-add constraints with multiple outputs"
multiOutConstraints do:
[: c |
(c ~~ aConstraint) ifTrue:
[c addToGraph.
self incrementalAdd: c]].
"restore old mark (which might have been messed up by re-adding constraints"
unmarkedFlag ifTrue: [currentMark _ oldMark].!
propagateFrom: vars watchFor: cycleVars execFlag: execFlag
"Recompute the walkabout strengths and stay flags of all variables downstream of the given variables. If execFlag is true, compute the values of variables whose stay flag is true. If cycleVars is not nil and any of the variables in cycleVars is encountered, stop and answer true. Otherwise, answer false."
removePropagateFrom: vars unsatisfiedInto: hotConstraints multiOutsInto: multiOuts
"Recompute the walkabout strengths and stay flags of all variables downstream of the given set of variables, collecting all unsatisfied downstream constraints into hotConstraints and all multiple output constraints into multiOuts."
"Retract the given constraint because it is being overridden by another constraint. If the constraint has only one output, no recomputation of DeltaBlue information is necessary and it can simply be unsatisfied. If the constraint has more than one output, retracting it is more expensive as we must resatisfying constraints downstream of its unmarked outputs. This is necessary because before the constraint can be reconsidered for satisfaction we must know the walkabout strengths of its variables in its absence."
| method |
method _ aConstraint whichMethod.
(method isNil) ifTrue: [^self]. "constraint is already retracted"
((aConstraint hasMultipleOutputs) and:
[(method bindings select: [: b | b == $o]) size > 1])
ifTrue: "retracting is expensive if there's more than one output"
"Attempt to find a method to satisfy the given constraint without creating a cycle. If successful, add the constraint and put all overridden constraints in the given collection."
| methods foundMethod bindings thingDatas i td oldC |
'Each partition of the constraint graph being debugged contains a collection of three-tuples (DebugConstraintRecords) of the form:
constraint -- the actual constraint object <Constraint>
glyph -- a glyph for the constraint <ConstraintGlyph>
solutions -- a collection of constraint methods, one per solution {Method}
Each tuple in a partition has the same number of solutions. The i-th solution for a partition is found by taking the i-th element of each tuple''s solutions collection. The first solution is always the current solution. The remaining solutions are the possible solutions. (The current solution should be among them unless there is a bug in the constraint solver!!).
'!
!DebugConstraintRecord methodsFor: 'accessing'!
constraint
^constraint!
constraint: aConstraint
constraint _ aConstraint.!
glyph
^glyph!
glyph: aConstraintGlyph
glyph _ aConstraintGlyph.!
solutions
^solutions!
solutions: aCollectionOfMethods
solutions_ aCollectionOfMethods.!
varGlyphs
^varGlyphs!
varGlyphs: aCollectionOfVariableGlyphs
varGlyphs _ aCollectionOfVariableGlyphs.! !
!DebugConstraintRecord methodsFor: 'operations'!
centerConstraint: graphCenter
"Place my constraint glyph at the center of its operands. If the constraint has only one operand, place it on the side of the operand farthest from the center of the graph."
"Initialize a new variable table entry for the given Reference."
thingData _ aReference thingData.
name _ 'v', thingData asOop printString.
type _ #internal. "assume internal until declared external"
reference _ aReference.
value _ aReference value.
"the following are used only during variable use analysis:"
tempFlag _ true. "assume temporary until shown otherwise"
constFlag _ true. "assume constant until shown otherwise"
constAncestors _ nil. "used to detect constants"! !
!ModuleVarTableEntry methodsFor: 'access'!
name
^name!
name: aName
name _ aName.!
reference
"Anwer my reference."
^reference!
thingData
^thingData!
value
^value! !
!ModuleVarTableEntry methodsFor: 'operations'!
classify
"Decide the type of this variable. This method assumes that we have already recorded the status of this variable for all possible solutions. A variable may be:
#external -- an external part
#virtual -- a virtual, external part (#virtual implies #external)
#internal -- invisible but holds state
#temporary -- does NOT hold state state
#constant -- stay flag is true for every flow, with the same ancestors"
"Note: non-external, non-constant, non-temporary variables are #internal"!
makeExternal: aReference
"Make this an external variable for the part with the given top-level reference."
type _ #external.
reference _ aReference.
tempFlag _ nil. "not relevant for external variables"
constFlag _ nil. "ditto"
constAncestors _ nil. "ditto"!
makeVirtual
"Make this entry be a virtual external variable."
(self isExternal) ifFalse:
[self error: 'Only external variables may be virtual parts!!'].
type _ #virtual.!
recordCurrentStatus
"Record the status of this variable in the current solution. This information will later be used to classify the variable; see 'classify' for further details."
"If no ancestors are currently recorded for me, remember this set and answer true. Otherwise, compare the previously recorded ancestors to the given set of ancestors and return true iff they are the same."
(constAncestors isNil)
ifTrue:
[constAncestors _ ancestors.
^true]
ifFalse:
[^self set: constAncestors equals: ancestors].!
set: setA equals: setB
"Answer true if setA contains exactly the same elements as setB."
'I am used as the model for CodeViews on Thing explanations. I support the basic text editing operations (cut, copy, paste, etc) and also the do it, print it, and inspect operations.'!
!Explanation methodsFor: 'initialization'!
thing: aThing
"Set my Thing."
thing _ aThing.! !
!Explanation methodsFor: 'adaptor'!
explainText
"Answer my Thing's explanation string as a Text object."
^thing explainText asText!
explainText: newExplanation
"Store the new explanation as a string in my Thing."
'I represent a disjunction (OR) of terms. ThingData
Each term has the form:
aStrength <= aWalkEquation
I store my terms as an OrderedCollection of Arrays of the form:
(aStrength, aWalkEquation)
Some of my terms can be evaluated at compile time. Any term that evaluates to ''false'' may be removed, as a false term cannot make the overall disjunction be true. On the other hand, any term that evaluates to ''true'' makes the entire disjunction evaluate to true, regardless of the other terms. A conjunction with no terms is false. (Such a conjunction probably had ''false'' terms that were removed during simplification.)
Instance variables:
constEquations... an OrderedCollection of pairs: (strength, walkEqn)
knownValue... caches the simplified value of this disjunction
"See if I have no terms and, if so, set my knownValue based on this."
"An empty disjunction (OR) is false because the false constant terms were filtered out."
(constEquations isEmpty)
ifTrue: [knownValue _ false].!
keepTermLeft: left right: right
"This method is used in simplifying module boolean equations. Answer true if the given term should be kept. Set the known value of the equation if possible. Assume that left side is a constant and that the right side has a constant part."
"Since this equation is a disjunction (OR), we can remove all false constant terms. A true constant term makes the entire disjunction true."
(left stronger: right constant)
ifTrue: [^false] "term is false, don't keep it"
ifFalse:
[(right vars isEmpty)
ifTrue:
["term is true, keep it and set known value"
knownValue _ true.
^true]
ifFalse:
["term value is not known, keep it"
^true]].!
simplify
"Simplify this equation by removing constant terms and setting its known value if possible. A constant term is one for which either:
a. the left and right sides are both constants and the left side
is NOT STRONGER than the right side (the term is true), or
b. the left side is a constant and is STRONGER than the
constant part of the right hand side (the term is false)."
| newEquations left right |
knownValue _ nil. "assume value cannot be determined"
!ModuleDisjunction class methodsFor: 'instance creation'!
new
^(super new) initialize! !
Object subclass: #HistoryQueue
instanceVariableNames: 'values next '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-Things-Support'!
HistoryQueue comment:
'I am a simple fixed-length queue that remembers the last <size> elements added to me. The last N elements (where N <= size) may be enumerated from oldest to most recent. The entire queue may be filled with a given value by the clearTo: operation.
Instance variables:
values -- an <Array> of element values
next -- index of the next location to store an element
!HistoryQueue class methodsFor: 'instance creation'!
new
^self new: 10!
new: size
^self basicNew initialize: size! !
Object subclass: #ThingLabII
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII'!
ThingLabII comment:
'ThingLab II was written by John Maloney and Bjorn N. Freeman-Benson under the guidance of Professor Alan Borning. We would like to acknowledge and thank some of the many other people who have contributed ideas and suggestions for ThingLab II (alphabetically):
Yu-Ying Chow
Robert Duisberg
Theresa Farrah
Bjorn N. Freeman-Benson
Robert Henry
Axel Kramer
Frank Ludolph
John Maloney
Scott Wallace
Mike Woolf
For a complete introduction and overview of the ThingLabII system, please read the ThingLab II Programmer''s Manual that has not yet been written.
The ThingLabII class is the "anchor" point for the ThingLabII system. Here is where global data such as the current constraint satisfaction planner is kept.'!
"Updates all the primitive Things in the system. Expensive!! This is used after changing the constraints for a primitive Thing to cause prototypes containing this Thing to be updated with new instances having the new prototypes. User-defined Things are not affected."
"Note: This algorithm assumes that structure of prototypes (i.e. what parts they have and what types those parts are) has not been changed. If prototype structure has been changed, running this algorithm a second time will take care of matters."
"ThingLabII updatePrimitives"
| allProtos initializedClasses proto |
allProtos _ self collectPrimitives.
initializedClasses _ IdentitySet new.
[allProtos isEmpty] whileFalse:
[proto _ allProtos detect: [: p | self allPartsOf: p in: initializedClasses].
Transcript show: 'Initializing ', proto class printString; cr.
proto class initialize.
allProtos remove: proto.
initializedClasses add: proto class.
proto destroy.
proto _ nil].
Transcript show: 'Updating Parts Bins'; cr.
PartsBin updateAllBins .
Transcript show: 'All Primitives Updated'; cr.! !
!ThingLabII class methodsFor: 'filing out'!
fileOutCategoriesMatching: patternString on: aStream
"File out on the given stream all methods in protocol categories matching the given pattern string. Both classes and metaclasses are examined."
| class metaClass |
Transcript cr; show: '*** Filing out ThingLabII System Changes ***'; cr; cr.
(SystemOrganization elements) do:
[: className |
class _ Smalltalk at: className asSymbol.
metaClass _ class class.
class organization categories do:
[: categoryName |
(patternString match: categoryName) ifTrue:
[self
fileOutClass: class
category: categoryName
on: aStream]].
metaClass organization categories do:
[: categoryName |
(patternString match: categoryName) ifTrue:
[self
fileOutClass: metaClass
category: categoryName
on: aStream]]].!
fileOutClass: aClass category: category on: aStream
"File out the given category of the given class on the given stream."
[filedOutClasses includes: p class superclass]) and:
[self allPartsOf: p in: filedOutClasses]].
(proto isNil) ifTrue:
[self error: 'Circular dependency among Primitive things'].
proto class fileOutOn: aStream.
aStream cr.
allProtos remove: proto.
filedOutClasses add: proto class].
aStream cr; close.
Transcript cr; cr; show: '*** Primitive Things Filed Out ***'; cr; cr.!
fileOutSystemOn: aStream
"File out the ThingLabII system on the given stream. This includes all classes and all changes to system classes. It does not include the primitive Things. You may need to adjust the order of the 'initialize' messages listed in fileOutPostludeOn:. You will definitely need to remove the class initialization messages sprinkled throughout the file."
instanceVariableNames: 'root path part putSymbol finalVarCache '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII'!
Reference comment:
'A reference is used to point to some part or sub-part of a Thing. It consists of a root Thing and a path. The path is the sequence of parts to traverse, starting from the Thing, to get to the referenced part.
Instance variables:
variable the Thing from which the path starts <Thing>
path an array of part names that goes from the root
to one part above the final destination {Symbol}
part the final path element <Symbol>
putSymbol the selector to send to the destination Thing to
set its value <Symbol>. This is expensive to
compute, so it is cached.
finalVarCache the final Thing in the path. It is to the final variable
that the get and put messages are sent. The final
variable is expensive to compute, so it is cached.
'!
!Reference methodsFor: 'initialize-release'!
destroy
"Break circular dependencies."
root _ nil.
path _ nil.
part _ nil.
putSymbol _ nil.
finalVarCache _ nil.!
on: aThing path: thePath
"Initialize myself to point to the part of aThing accessed by the given sequence of selectors (thePath). thePath may contain Symbols or Strings."
"Purge my finalVar cache. This is used when the structure of a Thing is changed during merging or unmerging or when the root is changed."
finalVarCache _ nil.!
topParent
"Answer the top-most parent of my root Thing."
^root topParent! !
!Reference methodsFor: 'cloning'!
cloneUsing: cloneDictionary
"Make a clone of myself using the mapping given by cloneDictionary."
| myClone |
myClone _ self shallowCopy.
myClone root: (cloneDictionary at: root).
^myClone! !
!Reference methodsFor: 'printing'!
longName
| s |
s _ (String new: 100) writeStream.
self fullPath do:
[: partName |
s nextPutAll: partName.
s nextPut: $..].
s skip: -1.
^s contents!
longPrintOn: aStream
(root isThing)
ifTrue: [root shortPrintOn: aStream]
ifFalse: [root printOn: aStream].
aStream nextPut: $..
path do: [: p | p printOn: aStream. aStream nextPut: $.].
part printOn: aStream.!
printOn: aStream
"Usually we show more information when the shift key is held down but in this case we show less. This is to reduce verbiage when printing constraints and methods and also to help you see more clearly when different constraints refer to the same variable."
'I represent a system-maintainable relationship, or "constraint", between a set of variables. I contain a set of methods that can be executed to enforce the constraint. If I am satisfied in the current data flow graph, the method used to enforce, or "satisfy", this constraint is stored in whichMethod. If I am not satisfied, whichMethod will be nil.
Note: Constraints must only be applied to the leaves of the Thing data hierarchy because there is currently no support for constraints at different levels (such as one constraint on a Point and another on its X part).
Instance variables:
variables... references to the variables to which this
constraint applies {Reference}
strength... the strength of this constraint <Strength>
methods... a collection of methods that can be used to
enforce this constraint {Method}
whichMethod... the method currently used to enforce this constraint
or nil if this constraint is not satisfied <Method>'!
!Constraint methodsFor: 'initialize-release'!
bind: refs strength: aSymbol
"Bind myself to the given set of references with the given strength."
self isBound
ifTrue: [self notify: 'This constraint is already bound!!'].
self variables: refs.
strength _ Strength of: aSymbol.!
destroy
strength _ nil.
symbols _ nil.
variables _ nil.
thingDatas _ nil.
methods _ nil.
inverseMethods _ nil.
whichMethod _ nil.
flags _ nil.!
initializeFlags
"Set a multiple output flag if this constraint has at least one method with multiple outputs. Clear other flags."
"WARNING: This method assumes that 'methods' has already been initialized."
flags _ 0.
methods do:
[: m |
((m bindings select: [: b | b == $o]) size > 1) ifTrue:
[flags _ flags bitOr: 2r100]].!
symbols: symbolList methods: methodList
"Initialize myself with the given methods. I am initialially unbound."
strength _ #unbound.
symbols _ symbolList.
variables _ Array new: symbolList size.
thingDatas _ Array new: symbolList size.
self methods: methodList asArray.
whichMethod _ nil.
self initializeFlags.! !
!Constraint methodsFor: 'DeltaBlue-public'!
addConstraint
"Add this constraint to the constraint graph and attempt to satisfy it."
self variables: variables. "make sure thingDatas cache is up to date"
self addToGraph.
DeltaBluePlanner incrementalAdd: self.!
removeConstraint
"Remove the constraint from the constraint graph, possible causing other constraints to be satisfied."
DeltaBluePlanner incrementalRemove: self.
self removeFromGraph.
variables do: [: var | var cleanUpThingData].! !
!Constraint methodsFor: 'DeltaBlue-private'!
addToGraph
"Add myself to the constraint graph as an unsatisfied constraint."
thingDatas do:
[: td |
td addConstraint: self.
(td determinedBy == self) ifTrue:
[td determinedBy: nil].
td removeUsedBy: self].
whichMethod _ nil.!
calculateDeltaBlueData: execFlag
"Calculate the walkabout strength, the stay flag, and (if execFlag is true) the real data values for the current outputs of this constraint. Answer a collection of ThingDatas for the outputs."
| stayFlag |
"assume: whichMethod has been set"
"My outputs are stay if either:
I am a stay constraint OR
I am not an input constraint such as a mouse constraint and
"Answer a collection of my methods that change the weakest of my variables and do not change any previously determined (i.e. marked) variable. Answer nil if there is no such method."
"Answer the walkabout strengths to be assigned to the outputs of the given method. The walkabout strength is the strength required to override the weakest upstream constraint determining the value of a given variable. The computation is complicated by the fact that some of my methods may not have inverses."
| outStrengths bindings i outStrength strongestOutOfInverse |
"Unsatisfy myself. Remove myself from the usedBy and determinedBy fields of my argument thingDatas and set whichMethod to nil. This is a noop if I am already unsatisfied."
| bindings i td |
(whichMethod notNil) ifTrue:
[bindings _ whichMethod bindings.
i _ thingDatas size.
[i > 0] whileTrue:
[td _ thingDatas at: i.
(td determinedBy == self) ifTrue:
[td determinedBy: nil].
((bindings at: i) == $i) ifTrue:
[td removeUsedBy: self].
i _ i - 1].
whichMethod _ nil].! !
!Constraint methodsFor: 'Blue-private'!
attemptSatisfaction: currentMark
"Consider myself for possible satisfaction. If I can be satisfied, answer the chosen method. Otherwise, answer nil. The outcome of considering a constraint for satisfaction may be:
1. it is established that the constraint can never be satisfied,
2. the constraint can be satisfied with some method, or
3. we don't know the values of enough variables to choose a method to satisfy the constraint at this time"
| possible chosen |
(self shouldConsider not | self isCommitted) ifTrue:
[^nil]. "this constraint is already committed or is not ready for consideration"
possible _ false. "assume false until shown otherwise"
"Set my set of methods and record their inverses. The inverseMethods array contains, for each variable of this constraint, an array of indices for the methods that have that variable as an input."
"Evaluate the given block for all outputs of my currently selected method."
whichMethod outDatasIn: thingDatas do: aBlock.!
strength
"Answer my strength."
^strength!
strength: aStrength
"Set my strength."
strength _ aStrength.!
symbols
"Answer a collection of symbolic names for my arguments. Each symbol in this collection is used to refer to the variable at the same location in the variables list."
^symbols!
thingDatas
"Answer the cache of ThingDatas for my variables."
^thingDatas!
variables
"Answer my variables (a collection of References)."
^variables!
variables: arrayOfReferences
"Set my variables and compute the thingDatas cache."
"Answer the method that I use to satisfy myself in the current solution. This is nil if I am not currently satisfied."
^whichMethod!
whichMethod: aMethod
"Set the method that I use to satisfy myself in the current solution."
whichMethod _ aMethod.! !
!Constraint methodsFor: 'applying'!
add: aStrengthSymbol on: r1 on: r2
"Add a copy of this constraint to the given references with the given strength. The receiver must be an unbound constraint."
^((self clone)
bind: (Array with: r1 with: r2)
strength: aStrengthSymbol)
addConstraint!
add: aStrengthSymbol on: r1 on: r2 on: r3
"Add a copy of this constraint to the given references with the given strength. The receiver must be an unbound constraint."
^((self clone)
bind: (Array with: r1 with: r2 with: r3)
strength: aStrengthSymbol)
addConstraint! !
!Constraint methodsFor: 'queries'!
doesSomething
"Some constraints, such as Stay and Edit constraints, are used only to control the planning process and have no actual code to execute. Answer false if I am such a constraint, otherwise answer true (the default behavior)."
^true!
isBound
"Answer true if I am bound to my arguments."
^strength ~~ #unbound!
isInput
"Normal constraints are not input constraints. An input constraint is one that depends on external state, such as the mouse, the keyboard, or a clock."
^false!
isRequired
"Answer true if this constraint is a required constraint."
^strength sameAs: (Strength required)!
isSatisfied
"Answer true if this constraint is satisfied in the current solution."
^whichMethod notNil!
isStay
"Normal constraints are not stay constraints. Stay constraints are a subclass."
^false!
isStrongerThan: aConstraint
"Answer true if I am stronger than the given constraint."
^self strength stronger: aConstraint strength!
shouldUseGiven: stayOptimizationFlag
"Answer true if this constraint should be added to the plan."
^(self doesSomething) and: "use this constraint if it does something AND"
[(whichMethod outputsAreStayIn: thingDatas) not]] " the outputs are not all stay)"! !
!Constraint methodsFor: 'set constraints'!
partlyBind: incompleteRefs
"To be used for Set Constraints. Partly bind myself to the given set of incomplete references. The references are incomplete because their root Things have not yet been filled in. The constraint will remain unbound but it will contain the given incomplete references. Warning: these references will not get copied by the clone operation."
self isBound
ifTrue: [self notify: 'This constraint is already bound!!'].
variables _ incompleteRefs.
thingDatas _ Array new: variables size.! !
!Constraint methodsFor: 'cloning'!
clone
"Answer a copy of this constraint."
^self cloneUsing: IdentityDictionary new!
cloneMethods: cloneDictionary
"Update my methods using the mapping given by cloneDictionary."
| newMethods newMethod |
newMethods _ methods collect:
[: m |
newMethod _ m cloneWith: cloneDictionary for: self.
(whichMethod == m) ifTrue: [whichMethod _ newMethod].
newMethod].
(newMethods ~= methods) ifTrue:
[methods _ newMethods].!
cloneUsing: cloneDictionary
"Make a clone of myself using the mapping given by cloneDictionary."
| myClone |
myClone _ self shallowCopy.
myClone cloneVariables: cloneDictionary.
myClone cloneMethods: cloneDictionary.
^myClone!
cloneVariables: cloneDictionary
"Update my variables using the mapping given by cloneDictionary."
self isBound
ifTrue:
[self variables:
(variables collect:
[: ref | ref cloneUsing: cloneDictionary])]
ifFalse:
[variables _ Array new: variables size].! !
!Constraint methodsFor: 'printing'!
definitionString
"Answer a string containing my definition for the constraint definer."
"Create and initialize a new constraint using the given Smalltalk expression as an equation. The equation should be of the form '(expr1) = (expr2)'. For example, the following builds a Sum constraint with methods to solve for any one variable in terms of the remaining two:
"Create and initialize a new constraint using the given method strings. The expressions in methodStrings are compiled to produce the actual method bodies for the constraint. For example, the following builds a one-way constraint that computes the magnitude of a vector:
'This class supports simple multiple-click and drag gestures. It uses the passage of time to determine the difference between a click, double-click, or drag gesture.'!
"Process user activity. This consists of either red button gestures or yellow button menu activity. Any other activity is handled by my superclass. Examples of gestures are: click, double-click, drag, and sweep (a special kind of drag). See the 'gestures' category for the full list."
"Perform action for a red button click at the given point. The default is to do vanilla red button activity."
self redButtonActivity.!
doubleClickAt: aPoint
"Perform action for a red button double-click at the given point. The default is to do vanilla red button activity."
self redButtonActivity.!
dragAt: aPoint
"Perform action for a red button drag starting at the given point. The default is to do vanilla red button activity."
self redButtonActivity.!
redButtonActivity
"If the subclass does not override a gesture messages, it is sent this message to perform vanilla red button activity. This default method does nothing."!
sweepAt: aPoint
"Perform action for a red button sweep starting at the given point. (A sweep is a diagonal down-and-right drag, used by some applications to sweep out an area for group selection.) The default is to do vanilla red button activity."
self redButtonActivity.! !
!GestureController methodsFor: 'menu support'!
menuActivity
"If the yellow button is pressed, this message is sent to the controller to handle the application menu. It is up to subclasses to override this message. This default method does nothing."! !
!GestureController methodsFor: 'private-timer'!
resetTimer
"Reset our timer by remembering the current value of the millisecond clock."
startTime _ Time millisecondClockValue.!
timeOut: timeOutInMilliseconds
"Compute the timer value by subtracting the time at which the timer was last reset from the current millisecond clock value. Answer true if the result is greater than timeOutInMilliseconds."
| timerVal |
timerVal _ Time millisecondClockValue - startTime.
"The button was held down too long for it to be a click so it is either a drag or a sweep. It is considered a sweep if the mouse has moved in definite downward-and-right manner between the time the button was depressed and now. (Note that the constants in this method may need to be changed if the timeout in possibleClickAt: is changed.)"
| delta |
delta _ sensor cursorPoint - aPoint.
((delta x > 1) & (delta y > 1))
ifTrue: [self sweepAt: aPoint]
ifFalse: [self dragAt: aPoint].!
possibleClickAt: aPoint
"Invoked when the red button is first depressed. If the button is released before the timeout period has elapsed, then there is at least one click and we must look for a second click. Otherwise, the gesture is a drag or sweep."
self resetTimer.
[(self timeOut: 150) not & sensor redButtonPressed]
whileTrue: ["wait for timeout or button up"].
(sensor redButtonPressed not) "has the button gone up?"
ifTrue: [self possibleDoubleClickAt: aPoint]
ifFalse: [self dragOrSweepAt: aPoint].!
possibleDoubleClickAt: aPoint
"Invoked after the first click (i.e. the button is up). If the button is depressed again before the timeout period has elapsed, then the gesture is a double click. Otherwise, the gesture is a single click. A single click is recorded immediately. Thus, a double click causes the sequence of messages: 'clickAt:' and 'doubleClickAt:' to be sent."
self resetTimer.
[(self timeOut: 260) not & sensor redButtonPressed not]
whileTrue: ["wait for timeout or button down"].
(sensor redButtonPressed) "has the button gone down?"
ifTrue: [self doubleClickAt: aPoint]
ifFalse: [self clickAt: aPoint].! !
SceneView subclass: #BasicThingView
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-UI-Thing Views'!
BasicThingView comment:
'A BasicThingView is used to display a Thing under construction. A ThingAdaptor is the model and a ThingConstructorController is the controller. When the user edits or moves some part of the thing under construction, this class computes the parts of the display that stay the same so that only the parts that are changing need be redisplayed. This class is also responsible for accepting new Things when they are are dragging into it from a PartsBin.'!
!BasicThingView class methodsFor: 'instance creation'!
on: aThing
"Create a new view on the given Thing."
^self new model: (ThingAdaptor on: aThing)!
openOn: aThing
"Open a view on the given Thing."
self
openWithSubview: (self on: aThing)
label: (aThing name).!
openOn: aThing from: aPartHolder zoomingFrom: fromRect to: openFrame
"Open a view on the given Thing zooming from fromRect to openFrame. Remember that this view was opened from the given partHolder."
self
openWithSubview: (self on: aThing)
label: (aThing name)
fromHolder: aPartHolder
zoomFrom: fromRect
to: openFrame.! !
AbstractMethod subclass: #Method
instanceVariableNames: 'block '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-Constraints'!
Method comment:
'I represent a normal (i.e. non-module) method.
Instance variables are (in addition to those inherited):
block... block to execute to enforce the constraint <BlockContext>
'!
!Method methodsFor: 'initialize-release'!
block: aBlock
"Set my code block. Used to initialize special constraints."
block _ aBlock.!
destroy
"Break potential cycles."
block _ nil.
super destroy.!
symbols: symbols methodString: methodString
"Initialize a method by compiling the given string considering the given collection of symbols to represent the parameters of the method (i.e. its inputs and outputs). A given variable may not be both an input and an output. Note: Free variables in the methodString will be handled as they are for any block, however the user is given a warning, since free variables in a constraint methods are unusual and may indicate a programmer error."
"Execute myself to enforce my constraint. refList contains all the References for my constraint."
block value: refList.! !
!Method methodsFor: 'private'!
blockPostfixForOuts: outNames allNames: allNames
"Answer a string to be used as the postfix when creating a block for this method. All output temporary variables are stored via their References in the argument array and the block is terminated."
| stream |
"make a stream and add separator to terminate user's method string"
stream _ WriteStream on: (String new).
stream nextPutAll: '.'; cr.
"build the expression postfix, creating assignments for all outputs"
1 to: allNames size do:
[: index |
(outNames includes: (allNames at: index)) ifTrue:
[stream tab; nextPutAll: '(vars at: '.
stream nextPutAll: index printString, ') value: '.
"Answer a string to be used as the prefix when creating a block for a method with the given input names. All constraint variables are declared as temporaries, in addition to the temporary variables from the method string. Input variable temporaries are initialized from the argument vector."
| stream |
stream _ WriteStream on: (String new).
"build the expression prefix, making all the variables look like temps"
stream nextPutAll: '| vars '.
argNames do: [: v | stream nextPutAll: v; space].
tempNames do: [: v | stream nextPutAll: v; space].
"Notify the user and answer nil if the input and output arg lists are not disjoint. Warn the user if the method code has free variables (these will be made into temporaries)."
outNames do:
[: v |
((inNames includes: v) and:
[allNames includes: v]) ifTrue:
[self error: v asString, ' cannot be both input and output!!']].
tempNames do:
[: v |
Transcript show:
'Warning: ''', v, ''' is assumed to be a temporary.'; cr].!
"Extract the input, output and temporary variable names from the Smalltalk expression represented by the given string. A temporary variable is one that is neither an input, an output, or a global. Answer an array containing the three lists (ins, outs, temps)."
"Compute and answer the bindings array for the given sets of variable names. The bindings array contains for each symbol in the constraint arguments vector:
$i if the variable is an input
$o if the variable is an output
$x if the variable is not referenced by this method"
'I support line clipping using the standard algorithm (see, e.g., Foley and vanDam''s book on interactive graphics). If I have zero area (because my height or width is zero) then I will report that no lines intersect me.'!
!ClippingRectangle methodsFor: 'clipping'!
clipFrom: beginPoint to: endPoint
"Clip the line (beginPoint, endPoint) and answer an array of three elements, (drawFlag, clippedBegin, clippedEnd). If the first element of the answer is false, the line is completely outside the clipping rectangle, and need not be displayed. If the first element of answer is true, the second two elements are the beginning and ending points of the clipped line."
"If we haven't rejected the line by now, some of it must lie within the clipping rectangle. If u0 or u1 are within the open interval (0..1), use them to compute the new line segment start and/or point."
instanceVariableNames: 'methods plan isPossibleEquation outWalkEqns dependencies '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-Module Compiler'!
ModuleSolution comment:
'I record information about one solution during the Module compilation process. I will eventually become one method of a Module constraint.'!
!ModuleSolution methodsFor: 'initialize-release'!
methods: methodList
"Initialize myself."
methods _ methodList.
plan _ nil. "filled in later"
isPossibleEquation _ nil. "filled in later"
outWalkEqns _ nil. "filled in later"
dependencies _ nil. "filled in later"! !
!ModuleSolution methodsFor: 'access'!
dependencies: aModuleDependency
"Record my input/output dependencies."
dependencies _ aModuleDependency.!
isPossibleEquation: aModuleAND
"Record my strength check equation."
isPossibleEquation _ aModuleAND.!
methods
"Answer the list of methods that comprise this solution."
^methods!
outWalkEqns: eqnList
"Record the walkabout strength equations for my outputs. These are in the same order as my dependencies list."
outWalkEqns _ eqnList.!
plan: aPlan
"Record my plan. The order of methods in the plan is different from the order in my 'methods' instance variable; the methods in the plan correspond to the order of constraints in the partition's constraint list whereas the order of methods in the plan is the correct execution order. The plan also omits null methods from stay and edit constraints."
"Compile the check, execute, and propagate methods for this solution and install them in module's class. Name them using given prefix string. Answer a new ModuleMethod for this solution."
self compileIsPossibleIn: module class prefix: prefix.
self compilePropagateIn: module class prefix: prefix.
^ModuleMethod
module: module
codeString: codeString
bindings: (self buildBindingArray: externalVars)
isPossible: prefix, 'isPossible'
execute: prefix, 'execute'
propagate: prefix, 'propagate'! !
!ModuleSolution methodsFor: 'private-method gen'!
appendStatementsOf: methodTree to: aStream
"Append the statements of the given method parse tree to the given stream. Omit the final '^self' statement."
| statements s |
"get method statements and remove final '^self'"
statements _ methodTree block statements.
statements _ statements copyFrom: 1 to: (statements size - 1).
"add statements to aStream"
statements do:
[: statement |
s _ statement printString.
s _ s copyFrom: 2 to: (s size - 1). "remove {} brackets"
aStream tab; nextPutAll: s; nextPut: $.; cr].!
buildBindingArray: constraintArgs
"Construct the bindings array for this solution for use in a ModuleMethod, using the given vector of external variables. The bindings array contains for each variable in the constraint arguments vector:
$i if the variable is an input
$o if the variable is an output
$x if the variable is not referenced by this method"
"Answer the code string and the referenced variable list for this solution. The code string is derived by concatenating all the statements of the non-nil methods of this solution in order."
"Details: The varible references in each method are renamed by using the reference and symbol vectors of its constraint and the varMap dictionary to map all the constraint argument names to their corresponding variable names in this context. We also inline expand all constant references at this time."
| stream varMap constraint parser tree |
stream _ (String new: 1000) writeStream.
varMap _ IdentityDictionary new: varTable size.
varTable do: [: v | varMap at: v thingData put: v].
plan do:
[: method |
constraint _ constraints detect: [: c | c methods includes: method].
parser _ EquationParser new.
tree _ parser parse: ('DoIt ', method codeString) readStream.
"Remap the variable reference in the given parseTree to use the local name and expand constant references. varMap is a dictionary mapping thingDatas to ModuleVarTableEntries."
"Details: First we construct a dictionary mapping the constraint's symbolic variable names to local names or constant expressions. Then we apply this mapping to the given parse tree."
| mappingDict varEntry newName |
mappingDict _ Dictionary new.
constraint variables with: constraint symbols do:
[: var : symbol |
varEntry _ varMap at: var thingData.
mappingDict at: symbol put:
((varEntry isConstant)
ifTrue: [varEntry literalTreeForUsing: encoder]
ifFalse: [encoder autoBind: varEntry name])].
^parseTree transformBy: "apply the mapping"
[: node |
(node isMemberOf: VariableNode)
ifTrue: [mappingDict at: (node name asSymbol) ifAbsent: [node]]
"Compile the 'xxxExecute' method in the given class."
| s internals |
s _ (String new: 1000) writeStream.
s nextPutAll: prefix, 'execute'.
s cr; cr.
self putPrefixOn: s varTable: varTable.
s nextPutAll: codeString.
self putPostfixOn: s.
internals _ (varTable select: [: v | v isInternal]) collect: [: v | v name].
self
compile: (s contents)
in: moduleClass
dontExpand: internals asSet.!
compileIsPossibleIn: moduleClass prefix: prefix
"Compile the 'xxxIsPossible' method in the given class."
| s |
s _ (String new: 1000) writeStream.
s nextPutAll: prefix, 'isPossible'.
s cr; cr; tab; nextPut: $^; cr.
isPossibleEquation storeOn: s.
self compile: (s contents)
in: moduleClass
dontExpand: #().!
compilePropagateIn: moduleClass prefix: prefix
"Compile the 'xxxPropagate' method in the given class."
| s temp |
s _ (String new: 1000) writeStream.
s nextPutAll: prefix, 'propagate'.
s cr; cr.
self ancestorsAndStayCodeOn: s.
s cr.
"generate code for the walkabout strength computations for all outputs not completely determined by stay constraints"
dependencies with: outWalkEqns do:
[: entry : eqn |
(entry stay not) ifTrue:
[s tab.
(entry outVar) thingDataCodeStringOn: s.
s nextPutAll: ' walkStrength: '; cr; tab; tab.
eqn storeOn: s.
s nextPut: $.; cr]].
"compile the 'isPossible' method"
self compile: (s contents)
in: moduleClass
dontExpand: #().!
putPostfixOn: aStream
"Answer a string to be used as the postfix when compiling my method. Statements are created to store the values of all outputs temporaries in their final destinations."
| outVar |
dependencies do:
[: d |
((d stay) & (d dependsOn isEmpty)) ifFalse: "not just a stay constraint"
[outVar _ d outVar.
aStream tab.
outVar putCodeStringOn: aStream.
aStream nextPutAll: outVar name.
aStream nextPut: $.; cr]].!
putPrefixOn: aStream varTable: varTable
"Append to the given stream a prefix to be used when compiling my execute method. Assignments statements are created to fetch the value of all variables into temporary variables. Unnecessary assignments statements are later removed during code optimization."
"Find a candidate assignement statement for inline expansion from the given list of statements. Answer the index of the candidate statement or nil if we don't find one."
| node v |
1 to: statements size do:
[: index |
node _ statements at: index.
(node isMemberOf: AssignmentNode) ifTrue:
[v _ node variable name.
(((dontExpand includes: v) not) and:
[(self var: v isNotAssignedToAfter: index in: statements) and:
[(self var: v usageCountAfter: index in: statements) <= 1]])
ifTrue: [^index]]].
^nil!
detectUnneededCandidateIn: statements
"Select a candidate unnecessary assignement statement from the given list of statements. Answer the index of the candidate statement or nil if we don't find one."
| node var |
1 to: statements size do:
[: index |
node _ statements at: index.
((node isMemberOf: AssignmentNode) and:
[node variable isTemp]) ifTrue:
[var _ node variable name.
((self var: var usageCountAfter: index in: statements) = 0)
ifTrue: [^index]]].
^nil!
optimize: statements dontExpand: dontExpand
"Do inline expansions on the given OrderedCollection of statements. The statement list is modified in place."
"Algorithm:
Repeat until nothing more can be done:
find an assignment statement s of the form 'v _ expr' such that
v is not in dontExpand AND
v is used at most once in the remaining statements AND
v is not assigned to in the remaining statements
remove s from the statements list
replace references to v with expr
Also, remove assignments to temporary variables that are never referenced in subsequent statements."
!ModuleSolution class methodsFor: 'instance creation'!
on: methodList
"Answer a new instance for the given solution."
^self new methods: methodList! !
AbstractMethod subclass: #OffsetMethod
instanceVariableNames: 'offset '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-Constraints-Special'!
!OffsetMethod methodsFor: 'initialize-release'!
offset: aNumber
offset _ aNumber.! !
!OffsetMethod methodsFor: 'DeltaBlue'!
execute: refList
"Execute myself to enforce my constraint. refList contains all the References for my constraint."
"Details: If my first reference is the output, then compute it by adding the offset to the value of the first reference. If my first reference is the input, do the inverse operation (subtracting the offset)."
'I am used to build menus on-the-fly. I maintain lists of menu items, actions (usually symbols to be sent as messages), and menu section dividing lines to which my clients may append new entries and lines by sending me the messages:
add: aString action: anAction
addLine
After the menu is constructed, it may be invoked with one of the following messages:
invoke: initialSelection
invoke
I am a subclass of ActionMenu, so I inherit a number of instance variables. The ones I am particularly concerned with are:
items _ an OrderedCollection of strings to appear in the menu
selectors _ an OrderedCollection of Symbols to be used as message selectors
lineArray _ an OrderedCollection of line positions
lastLine _ used to keep track of the last line to avoid making duplicate entries in lineArray'!
!CustomMenu methodsFor: 'initialize-release'!
initialize
items _ OrderedCollection new.
selectors _ OrderedCollection new.
lineArray _ OrderedCollection new.
lastLine _ 0.! !
!CustomMenu methodsFor: 'construction'!
add: aString action: aSymbol
"Add the given string as the next menu item. If it is selected, the given action (usually but not necessarily a symbol) will be returned to the client."
items addLast: aString.
selectors addLast: aSymbol.!
addLine
"Append a line to the menu after the last entry. Suppress duplicate lines."
(lastLine ~= items size)
ifTrue:
[lastLine _ items size.
lineArray addLast: lastLine].! !
!CustomMenu methodsFor: 'invocation'!
invoke
"Invoke the menu with no initial selection."
^self invoke: nil!
invoke: initialSelection
"Invoke the menu with the given initial selection (i.e. one of my 'action' symbols). Answer the 'action' selector associated with the menu item chosen by the user or nil if none is chosen."
!CustomMenu class methodsFor: 'instance creation'!
new
^(super new) initialize! !
!CustomMenu class methodsFor: 'example'!
example
"CustomMenu example"
| menu |
menu _ CustomMenu new.
menu add: 'apples' action: #apples.
menu add: 'oranges' action: #oranges.
menu add: 'peaches' action: #peaches.
menu add: 'pears' action: #pears.
^menu invoke: #peaches! !
Thing subclass: #ModuleThing
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-Things'!
ModuleThing comment:
'I am an abstract class for compiled ThingLabII Things. These Things are known as Modules. Do NOT EVER subclass a subclass of ModuleThing. Very bad!! Even worse than for Things.
My protocol is fairly simple because most of the work is done at compile time.
'!
!ModuleThing methodsFor: 'public-testing'!
isStructureModifiable
"Modules cannot be further modified."
^false! !
!ModuleThing methodsFor: 'cloning'!
clonePass1: cloneDictionary
"ModuleThings must clone their internal parts as well as their normal parts."
| myClone oldPart newPart |
myClone _ super clonePass1: cloneDictionary.
"clone my internal parts"
(super class instOffset + 1) to: (self class instOffset) do:
[: i |
oldPart _ self instVarAt: i.
newPart _ oldPart cloneUsing: cloneDictionary.
myClone instVarAt: i put: newPart].
"redundant, but good documentation:"
cloneDictionary at: self put: myClone.
^myClone! !
!ModuleThing methodsFor: 'DeltaBlue'!
propagateFrom: inDatas to: outData
"Used by ModuleMethods to propagate stay values from the given inputs to the given output."
outData stay:
((inDatas isEmpty) or:
[(inDatas detect: [: var | var stay not] ifNone: [nil]) isNil]).! !
"Use special menu if collapsed. Otherwise, use my custom blueButtonMenu, which omits 'collapse'."
| selector i |
view isCollapsed
ifTrue: [^super blueButtonActivity].
(BlueButtonMenu isNil) ifTrue:
[BlueButtonMenu _ ActionMenu
labels: ' under \ move \ frame \ close ' withCRs
lines: #(3)
selectors: #(under move frame close)].
i _ BlueButtonMenu startUp.
(i > 0) ifTrue: [self perform: (BlueButtonMenu selectorAt: i)].!
close
"Do zooming animation and remember the current view display box on close. In order to do the animation, fromFrame must be non-nil and in order to remember the display box fromHolder must be non-nil."
"Give access to menus when the mouse (red button) goes down in the label part of my view. If the mouse is in the text box, act as though the yellow button were pressed (the application menu, by convention) otherwise, act as though the blue button were pressed (the view menu, by convention)."
"Initialize myself with the given references, strength, and offset."
strength _ Strength of: aSymbol.
symbols _ #(v1 v2).
self variables: (Array with: ref1 with: ref2).
self methods: (self getMethodsFor: offset).
whichMethod _ nil.
self initializeFlags.! !
!OffsetConstraint methodsFor: 'private'!
getMethodsFor: offset
"To save space, we maintain a Dictionary of shared methods for offsets in the range [-25..25]. Answer the methods array from this Dictionary or a newly created one."
'I am used by the ModuleCompiler and the Thing debugger to enumerate the possible solutions to a set of constraints. There are various options to control which possibilities are presented. One may get all possible solutions, only those without cycles, or only those that without cycles that have unique input/output modes.'!
!MultiSolver methodsFor: 'initialization'!
constraints: constraintList
"Initialize myself with the constraints of the given collection."
| sorter |
"sort constraints in order of decreasing strength"
sorter _ (SortedCollection new: 100)
sortBlock: [: i : j | i strength stronger: j strength].
sorter addAll: constraintList.
constraints _ sorter asOrderedCollection.
"re-order the constraints in constraintList to match constraints"
"Answer all non-cyclic solutions. This can take some time if there are a large number of solutions."
^solutions select: [: s | (self hasCycle: s) not]!
uniqueModeSolutions
"Answer a set of non-cyclic solutions that handle mutually exclusive input/output modes over the external variables. This can only be done if I know what the external variables are (i.e. if my modeTable is not nil)."
| solutionSet |
(modeTable isNil) ifTrue:
[^self error: 'The external variables were not defined.'
"use the constraints:externalVars: initialization message"].
"Answer true if the given constraint is stronger than all unsatisfied constraints that could potentially determine the given method's outputs. If any of the method's outputs are external variables, we can't be sure that it is strong enough. We assume that the given method is possible -- that is, that none of its outputs is already determined by another constraint."
| maxOutStrength |
maxOutStrength _ Strength absoluteWeakest.
aMethod outDatasIn: theConstraint thingDatas do:
[: outVar | "examine all output vars of the method"
(externalVars includes: outVar) ifTrue: [^false].
outVar constraints do:
[: c | "examine all unsatisfied constraints except theConstraint"
((c ~~ theConstraint) and:
[(satisfied includes: c) not]) ifTrue:
[maxOutStrength _
maxOutStrength strongest: c strength]]].
^theConstraint strength stronger: maxOutStrength!
modeVector
"Answer a mode vector for the current solution. A mode vector is a string of 'i' and 'o' characters (e.g. 'iio') that indicates whether each var in externalVars is an input or output."
"Details: v is output if it is in determined OR if it is an output of the last method (if that method isn't nil). We have to check the last method outputs because the last method's outputs are not recorded in determined to save cost of copying determined (for backtracking). This is a messy efficiency hack that saves about 12%; it would be cleaner to to update and restore 'determined' even when processing the last method."
| lastMethodOuts modeVector i |
lastMethodOuts _ IdentitySet new.
(methods last notNil) ifTrue:
[methods last outDatasIn: (constraints last thingDatas) do:
"Consider the given set of possible methods for the given constraint and answer true if the nil method is allowed. If the constraint is required or if it can be satisfied without interferring with any stronger constraint, the nil method is not allowed."
"If the constraint is required, nil is not allowed."
(theConstraint isRequired) ifTrue: [^false].
"
Look for a method that could be used to satisfy the given constraint without interferring with a stronger constraint. If we find one, don't allow nil as a possible method."
possibleMethods do:
[: m |
(self couldUse: m for: theConstraint) ifTrue: [^false]].
^true "nil method is okay"!
outputsOf: aMethod notDeterminedFor: aConstraint
"Answer true if none of the outputs of the given method has been determined."
aMethod outDatasIn: aConstraint thingDatas do:
[: outVar |
(determined includes: outVar) ifTrue: [^false]].
^true "none of the outputs has been determined"!
possibleNextMethods
"Answer a collection of possible methods for solving the next constraint. A nil in this collection means that the constraint need not be satisfied."
| c possibleMethods |
c _ constraints at: (methods size + 1).
possibleMethods _ c methods select:
[: m | self outputsOf: m notDeterminedFor: c].
^(self nilAllowedFor: c possibleMethods: possibleMethods)
ifTrue: [possibleMethods copyWith: nil]
ifFalse: [possibleMethods]!
recordSolution: aSolution
"Record the given solution in the mode table, if there is one."
"Solve the current constraint using the given method then find all legal solutions reachable from this state. We use a recursive, depth-first enumeration technique."
"Details: The list of currently determined constraints must be saved and then restored when we are done to allow proper backtracking. However, this list need only be copied if we are going to change it (i.e. the current constraint is satisfied and it is not the last constraint), so the copy is done lazily."
"Answer the strength of the strongest unsatisfied constraint in the given solution or a Strength absoluteWeakest if all the constraints are satisfied."
"Construct the variables map, a dictionary that maps each variable to its own row index. Also initializes the transition matrix."
| var |
variables _ IdentityDictionary new: 16.
constraints do:
[: c |
(c variables) do:
[: ref |
var _ ref thingData.
(variables includesKey: var) ifFalse:
[variables at: var put: (variables size + 1)]]].
transitions _ (1 to: variables size) collect:
[: i | Array new: variables size withAll: false].!
hasCycle: methodList
"Answer true if the given collection of methods contains a cycle."
"Details: This is implemented by finding the transitive closure of the directed graph formed by the methods of methodList. If any variable is its own ancestor in the transitive closure then there is a cycle in the solution. We use a boolean matrix representation to compute the transitive closure. The element [i,j] of this matrix is true if the value of variable i depends directly or indirectly on the value of variable j in the dataflow given by the method list."
| status |
self initializeTransitionMatrix: methodList.
status _ #progress.
[status == #progress] whileTrue:
[status _ self propagateAncestors.
(status == #cycleDetected) ifTrue:
[^true]]. "cycle detected"
^false "no cycle detected"!
initializeTransitionMatrix: methodList
"Initialize the transition matrix for the given list of methods. The entry at [i,j] in this matrix is true if variable j is an ancestor of variable i."
| matrixSize i row j m thingDatas |
"first, clear transition matrix"
matrixSize _ transitions size.
i _ matrixSize.
[i > 0] whileTrue:
[row _ transitions at: i.
j _ matrixSize.
[j > 0] whileTrue:
[row at: j put: false.
j _ j - 1].
i _ i - 1].
"now, register initial ancestors based on the methods"
i _ methodList size.
[i > 0] whileTrue:
[m _ methodList at: i.
(m notNil) ifTrue:
[thingDatas _ (constraints at: i) thingDatas.
m outDatasIn: thingDatas do:
[: out |
row _ transitions at: (variables at: out).
m inDatasIn: thingDatas do:
[: in | row at: (variables at: in) put: true]]].
i _ i - 1].!
propagateAncestors
"Make one pass over the transition matrix propagating the ancestors relation. Answer one of:
#done -- if no progress was made
#progress -- if progress was made but no cycle was detected
#cycleDetected -- if a cycle was detected."
| matrixSize progress i descendent row |
matrixSize _ transitions size.
progress _ false.
i _ 1.
[i <= matrixSize] whileTrue:
[descendent _ 1.
[descendent <= matrixSize] whileTrue:
[row _ transitions at: descendent.
(row at: i) ifTrue:
[(self propagateFrom: i to: descendent) ifTrue:
[progress _ true.
(row at: descendent) ifTrue:
[^#cycleDetected]]].
descendent _ descendent + 1].
i _ i + 1].
progress
ifTrue: [^#progress]
ifFalse: [^#done].!
propagateFrom: sourceVar to: descendentVar
"OR the ancestors of sourceVar (its row) into descendentVar's row. Answer true if descendentVar's row changed."
"Answer a collection of cycle-free solutions to the given set of constraints but only include one solutions for each input/output 'mode' of the set of externally visible variables. For example, if a, b, and c are the external variables then the modes are (in, in, in), (in, in, out), (in, out, in), and five more."
"Compute the backgroundForm and the two lists, visibleForeground and selectedForeground. These are used by the 'displayFeedback' and 'displayFeedbackWithBox:width:' operations."
'I am an abstract class for primitive Things. Primitive Things cannot be structurally changed.'!
!PrimitiveThing methodsFor: 'initialize-release'!
initializeConstraints
"Override this method to add constraints when initializing the prototype of a PrimitiveThing. This method is called after the structure of the Thing is initialized. By default, no constraints are added."!
initializeStructure
"Override this method to initialize the part-whole structure when initializing the prototype of a PrimitiveThing. By default, no Thing subparts are created."!
initializeValues
"Override this method to initialize part values when initializing the prototype of a PrimitiveThing. This method is called after the structure of the Thing is initialized and constraints have been added. By default, no initial values are provided."! !
'I represent methods for compiled ModuleThings. I have a pointer to the ModuleThing instance and a bunch of selectors to perform various operations on that ModuleThing in order to plan for and perform constraint satisfaction.
Instance variables (in addition to those inherited):
owner... my ModuleThing
executeSel... selector to compute the values of my outputs
checkSel... selector to compute if I am an appropriate method
walkSel... selector to compute the walkabout strengths of my outputs
ancestorSel... selector to compute the ancestors of my outputs
"Execute myself to enforce my constraint. Do this by executing the method compiled for that purpose. refList is ignored."
module perform: executeSel.!
isPossibleMethodGiven: constraintStrength
"Answer true if I am a possible method given the current walkabout strengths of my variables. Compute the answer by executing the method compiled for that purpose."
"Update the walkabout strengths and stay flags for all my outputs and answer the output ThingDatas. Do this by executing the method compiled for that purpose."
module perform: propagateSel.
^myConstraint outDatas! !
!ModuleMethod methodsFor: 'cloning'!
cloneWith: cloneDictionary for: ignored
"Make a clone of myself using the mapping given by cloneDictionary."
[: part | model select: (model thing perform: part)].! !
!ThingModuleView methodsFor: 'displaying'!
computeBackground
"Compute the backgroundForm and the two lists, visibleForeground and selectedForeground. These are used by the 'displayFeedback' and 'displayFeedbackWithBox:width:' operations."
"A flag is maintained to allow me to gracefully give up control (see isControlActive and isControlWanted) when switching between View/Controller pairs within the same top view."
doneFlag _ aBoolean.! !
!SceneController methodsFor: 'gestures'!
clickAt: aPoint
"If the mouse is clicked over a glyph that wants mouse input and we are in 'operate' mode, pass the mouse to it. Otherwise, select the glyph under aPoint. If the shift key is depressed, the glyph's inclusion in the selection is toggled: that is, it is added to the selection if it is not currently selected and removed from the selection if it is currently selected."
"first, try to process mouse input for the glyph at aPoint"
"Handle a double-click action by selecting everything."
self selectAll.
sensor waitNoButton.!
dragAt: aPoint
"Handle a drag action. If aPoint is over a glyph that is interested in mouse actions, let that glyph handle the mouse. Otherwise, move or scroll depending on whether or not the given point is over a selectable glyph or not."
| glyph |
"first, try to process mouse input for the glyph at aPoint"
(self processMouseAt: aPoint) ifTrue: [^self].
"if that fails, handle the normal move-or-scroll situation"
glyph _ self glyphAt: aPoint.
(glyph notNil)
ifTrue:
["if the glyph is not in the selection, select it"
"If the given point is over a glyph that is interested in mouse actions, let that glyph handle the mouse and answer true. Otherwise, answer false."
| mouseGlyph |
mouseGlyph _ self mouseGlyphAt: aPoint.
(mouseGlyph notNil)
ifTrue: [self passMouseTo: mouseGlyph. ^true]
ifFalse: [^false].!
sweepAt: aPoint
"First, try to pass the mouse to any glyphs under aPoint that want it. If there aren't any mouse input glyphs by there is a selectable glyph under aPoint, then select it and drag the selected glyphs. Otherwise, handle the sweep gesture by doing an area-select. If the shift key is down, then toggle select all enclosed glyphs. Otherwise, clear the selection first."
"first, try to process mouse input for the glyph at aPoint"
(self processMouseAt: aPoint) ifTrue: [^self].
"if that fails, handle the normal move-or-area-select situation"
((self glyphAt: aPoint) notNil) "check for a drag situation"
ifTrue: [self dragAt: aPoint]
ifFalse:
[self
selectAreaAt: aPoint
toggleFlag: (sensor leftShiftDown)].! !
!SceneController methodsFor: 'menu handling'!
argument
"Answer the argument for unary operation from the model's selection. There must be exactly one object selected. If so, answer it. Otherwise, answer nil."
"Present the yellow button menu and determine which menu item, if any, the user selected. If an item was selected, then send that message to the object designated as the menu message receiver. Remember the menu item across menu invocations."
| menu item |
menu _ self yellowButtonMenu: (sensor leftShiftDown).
(menu isNil) ifTrue: [^self].
item _ menu invoke: lastMenuItem.
lastMenuItem _ item.
(item notNil) ifTrue: [self perform: item].!
yellowButtonMenu: debugging
"Answer my yellow-button menu, constructed by sending myself the message 'addMenuItems: debugging.' Items are appended to the CustomMenu myMenu; this allows subclasses to augment the menu provided by their superclass without the maintainance headache of copying the menu creation code into the subclass."
myMenu _ CustomMenu new.
self addMenuItems: debugging.
^myMenu! !
!SceneController methodsFor: 'menu operations'!
addMenuItems: debugging
"Answer my yellow-button menu given the current selection and possibly some other view or controller state. The goal is to present in the menu only those possibilities which are legal commands at this juncture. If debugging is true, present a additional options which might be useful to implementors and other gurus."
myMenu add: ' scroll ' action: #scroll.
myMenu add: ' area ' action: #selectArea.
myMenu addLine.
myMenu add: ' all ' action: #selectAll.
(model selected size > 0) ifTrue:
[myMenu add: ' none ' action: #clearSelection].
myMenu addLine.!
clearSelection
"Unselect everything."
model clearSelection.
view displayScene.!
scroll
"Wait for the mouse button to be pressed, then scroll."
Cursor hand showWhile: [sensor waitButton].
self scrollAt: sensor cursorPoint.!
selectAll
"Select all selectable glyphs."
model clearSelection.
model selectableGlyphs do: [: g | model select: g].
view displayScene.!
selectArea
"Select everything in a rectangular area specified using the mouse. If the shift key is down, toggle select everything in the area."
"As the user moves the cursor, draw a selection rectangle, scrolling if the mouse leaves my view. When the red button is released, select all selectable glyphs inside the selection rectangle."
"Select the glyph at aPoint. If toggleFlag is true, add/remove the glyph to/from the selection. Otherwise add the glyph. If aPoint is not over any glyph then clear the selection."
| glyph |
glyph _ self glyphAt: aPoint.
(glyph notNil)
ifTrue:
[((model selected includes: glyph) not & toggleFlag not)
ifTrue: [model clearSelection].
toggleFlag
ifTrue: [model toggleSelect: glyph]
ifFalse: [model select: glyph]]
ifFalse: [model clearSelection].! !
!SceneController methodsFor: 'keyboard'!
readKeyboard
"Keystrokes are sent to all selected Things that are interested in keyboard input."
'I am used to relate a variable to the current y-coordinate of the mouse. I contain an offset to normalize the coordinate system to one convenient for the target variable. I have only one method with no inputs and one output.'!
'I am used to relate a variable to the current x-coordinate of the mouse. I contain an offset to normalize the coordinate system to one convenient for the target variable. I have only one method with no inputs and one output.'!
"Adds an invisible sub-view whose controller is myself. This allows me to support the 'the application menu is available from the center of the top view's label' scheme, which tries to send the #menuActivity message to the first subview. This method should be executed first to ensure that this is the first sub-view."
| firstSubview |
firstSubview _ (FormView new)
model: (Form extent: 0@0);
borderWidth: 0;
controller: self.
topView
addSubView: firstSubview align: 0@0 with: 0@0.!
buildInside: aTopView
"Set up my controls within the given view."
self addMenu: aTopView. "this should be done first"
"Undo changes to the currently displayed settings. This is done by removing all subview and rebuilding them, resetting the settings of the controls in the process."
"Accept the changes, if there are any, and close this explanation view."
(self textHasChanged)
ifTrue: [view accept: self text from: self].
view topView controller close.!
menuActivity
self yellowButtonActivity.! !
Model subclass: #Scene
instanceVariableNames: 'glyphs selected '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-UI-Framework'!
Scene comment:
'A Scene is a two-dimensional diagram or picture composed of displayable objects called glyphs. Each glyph must respond to the basic protocol for Glyphs (see class Glyph). A scene also maintains a list of selected glyphs and can enumerate various kinds of the glyphs: visible, selectable, and input-accepting.
Scenes maintain a list of selected glyphs.
'!
!Scene methodsFor: 'initialize-release'!
initialize
glyphs _ OrderedCollection new.
selected _ Set new.! !
!Scene methodsFor: 'glyphs access'!
allGlyphs
"Answer the set of all glyphs. By default, this is just the visible glyphs."
^self visibleGlyphs!
inputGlyphs
"Answer the set of glyphs that accept input."
^glyphs select: [: g | g wantsMouse | g wantsKeystrokes]!
selectableGlyphs
"Answer the set of glyphs that are selectable. By default, this is just the visible glyphs."
^self visibleGlyphs!
visibleGlyphs
"Answer the set of glyphs that are visible."
^glyphs! !
!Scene methodsFor: 'glyphs'!
addGlyph: aGlyph
glyphs addLast: aGlyph!
isChanging: aGlyph
"Answer true if the give glyph is undergoing changes that could effect how it is displayed. For example, this would be 'true' for glyphs being dragged with the mouse. By default, all glyphs are unchanging."
^selected includes: aGlyph!
moveToFront: glyphsList
"Move the glyphs in the collection glyphsList to the back of my glyph collection so that they will be displayed last and hence appear in front of any overlapping glyphs."
| temp |
glyphsList do: [: g |
temp _ glyphs remove: g ifAbsent: [nil].
(temp notNil) ifTrue: [glyphs addLast: temp]].!
removeGlyph: aGlyph
glyphs remove: aGlyph ifAbsent: [].
selected remove: aGlyph ifAbsent: [].! !
!Scene methodsFor: 'selections'!
clearSelection
selected _ selected species new.!
deselect: aGlyph
selected remove: aGlyph ifAbsent: [].!
select: aGlyph
selected add: aGlyph.!
selected
^selected!
toggleSelect: aGlyph
"Toggle the selection of aGlyph. That is, if aGlyph is currently selected, deselect it; if it is not selected, select it."
'I support startup pictures. The picture will also appear after you snapshot. The startup picture is typically stored in a file such as ''ThingLabII.form''. I go away when the user presses any mouse button.'!
!IntroPicture methodsFor: 'control defaults'!
isControlActive
"Hack, hack!! Seize control and don't give it up until the user clicks any mouse button."
"Answer the rectangle containing just the text part of my label. This rectangle is in the coordinate system whose origin is the top-left corner of my label."
'This is is the top-level of the Module compiler that converts a Thing and a list of external parts into a ModuleThing and a set of ModuleConstraints.'!
!ModuleCompiler methodsFor: 'compiling'!
compileThing: aThing
"This is the entry point of the ModuleCompiler. The module compiler manipulates a working copy of the original Thing to construct the new Module."
"Construct module constraints for all partitions and add them to newThing."
| constraint |
partitions do:
[: p |
constraint _ p compileFor: newThing.
"allocate thingDatas before adding the constraint; the module methods assume they are there"
constraint variables do: [: v | v thingDataOrAllocate].
newThing addConstraint: constraint].!
constructNewClass
"Build a new class for the module. This class will be a subclass of ModuleThing and will have instance variables for the external parts and the internal variables. Access methods must be compiled for the external parts."
"Construct a set of references for the constrained subparts of the external parts of workThing. The references must contain paths starting with external part names. Use this set of references to declare the external variables for each partition."
"identify the external variables in each partition"
partitions do:
[: partition |
partition declareExternalVars: externalRefs].!
initializePrototype
"Initialize the external parts of the prototype with clones of the corresponding parts from workThing. Also initialize the internal variables."
| tempThing extParts partRef allThingDatas cloneDictionary clone partName index |
tempThing _ oldThing clone.
"first, make sure external parts are not entangled with any doomed internal parts. this is done by isolating the non-external parts from merges and removing their constraints. we must also remove the top-level constraints from tempThing."
extParts _ (tempThing class externalParts) asSet.
tempThing thingPartsAndNamesDo:
[: part : name |
(extParts includes: name) ifFalse:
["isolate the part"
partRef _ part referenceToYourself.
part isolate: partRef within: partRef.
"remove all constraints attached to the part"
allThingDatas _ Set new.
part allThingDatasInto: allThingDatas.
allThingDatas do:
[: thingData |
BusyCursor inc.
thingData constraints do: [: c | c removeConstraint]]]].
tempThing constraints copy do: [: c | c destroy].
tempThing constraints: tempThing constraints species new.
"now, copy the external parts to the new module prototype. this is done using the cloning operation but moving the parts and changing the clone dictionary midway through."
cloneDictionary _ IdentityDictionary new: 200.
clone _ tempThing clonePass1: cloneDictionary.
"move the newly copied external parts to their new home"
newThing class partNamesAndIndices do:
[: partAndIndex |
partName _ partAndIndex at: 1.
index _ partAndIndex at: 2.
part _ clone perform: partName.
newThing instVarAt: index put: part.
part removeParent: clone.
part addParent: newThing].
"fix all references by changing old references to tempThing to go to newThing, using pass2 of the cloning operation."
cloneDictionary at: tempThing put: newThing.
clone clonePass2: cloneDictionary.
partitions do: [: p | p initializeInternalVarsFor: newThing].
tempThing destroy.!
numberPartitions
"Assign a unique number to each partition."
| nextId |
nextId _ 0.
partitions do:
[: partition |
partition setID: (nextId _ nextId + 1)].!
removeExternalPartConstraints
"Remove constraints owned by the external parts from all partitions."
| externalConstraints part |
"first, collect the constraints owned by external parts"
externalConstraints do: [: c | c removeConstraint; destroy].!
removePrivateAndEmptyPartitions
"Filter out partitions with no external variables since these partitions cannot be seen from outside the module. Filter out partitions which have no constraints because they required no further processing."
partitions _ partitions select:
[: p | (p hasExternalVars) and: [p isEmpty not]].! !
"Create a new instance of me and use it to compile the given thing into a Module."
^self new compileThing: aThing! !
Constraint subclass: #EditConstraint
instanceVariableNames: ''
classVariableNames: 'SharedMethods '
poolDictionaries: ''
category: 'ThingLabII-Constraints-Special'!
EditConstraint comment:
'I am used to mark variable that the user wishes to edit. I have only one method with no inputs and one output. My method does nothing.'!
!EditConstraint methodsFor: 'initialize-release'!
ref: ref strength: aSymbol
"Initialize myself with the given reference and strength."
strength _ Strength of: aSymbol.
symbols _ #(a).
self variables: (Array with: ref).
"initialize methods list shared by all instances"
(SharedMethods isNil) ifTrue:
[SharedMethods _ Array with:
((Method new)
codeString: '"edit"';
block: [: vars | "I do nothing" vars _ nil];
bindings: 'o')].
self methods: SharedMethods.
whichMethod _ nil.
self initializeFlags.! !
!EditConstraint methodsFor: 'queries'!
doesSomething
"Edit constraints have no effect other than to control the planning process."
^false!
isInput
"Normal constraints are not input constraints. An input constraint is one that depends on external state, such as the mouse, the keyboard, or a clock."
"Build a dictionary of all constrained variables. The dictionary maps ThingDatas to VariableGlyphs. The information is extracted from the partitions, which must already have been built."
| constraint glyph |
variables _ IdentityDictionary new.
partitions do:
[: partition |
partition constraintRecords do:
[: cRec |
cRec constraint variables do:
[: v |
(variables includesKey: v thingData) ifFalse:
[glyph _ VariableGlyph
named: (v longName)
at: (self nextPlace).
variables at: v thingData put: glyph]].
cRec varGlyphs:
(cRec constraint variables collect:
[: v | variables at: v thingData])]].!
on: aThing
"Initialize a new instance of me on the given Thing and build the partitions and variables table."
super initialize.
thing _ aThing.
currentPartition _ 1.
self buildButtons.
self buildPartitions.
self buildVariableTable.
partitions do:
[: partition |
partition solution: 0.
partition centerConstraints].
self firstPartition.! !
!ThingDebug methodsFor: 'glyphs'!
isChanging: aGlyph
"Answer true if the following glyph is changing. This is the case if the glyph is selected or if it is a ConstraintGlyph and one of its associated variables is selected."
(selected includes: aGlyph) ifTrue: [^true].
(aGlyph isMemberOf: ConstraintGlyph) ifTrue:
[aGlyph allVarGlyphs do:
[: var |
(selected includes: var) ifTrue: [^true]]].
^false!
selectableGlyphs
^glyphs select: [: g | (g isMemberOf: ButtonGlyph) not]! !
!ThingDebug methodsFor: 'partitions'!
firstPartition
"Display the first partition."
currentPartition _ 1.
self updateGlyphs.!
nextPartition
"Display the next partition. Wrap around at the end of the list of partitions."
"Display solution zero, the current solution, for the current partition."
(partitions at: currentPartition) solution: 0.!
nextAlternative
"Display the next alternative solution for this partition. Wrap around at the end of the solutions list. If the alternative solutions have not yet been computed for this partition, compute them now."
"Display the next previous solution for this partition. Wrap around at the beginning of the solutions list. If the alternative solutions have not yet been computed for this partition, compute them now."
"Completely rebuild my data structures from my Thing. This is useful when the structure of the underlying Thing has been changed but the user wants to keep using the same ThingDebugView."
self on: thing.!
toggleConstraintLabels
"Toggle the visibility of the constraint labels of the current partition."
(partitions at: currentPartition) toggleLabels.!
toggleVariableLabels
"Toggle the visibility of all variable labels."
(variables asOrderedCollection first labelIsHidden)
ifTrue: [variables do: [: v | v showLabel]]
ifFalse: [variables do: [: v | v hideLabel]].!
updateCurrentSolutions
"Update the current solution of each partition."
partitions do:
[: partition |
partition updateCurrentSolution].! !
!ThingDebug methodsFor: 'private'!
computeAllSolutions
"This can be very expensive for large partitions!! Find and record all the possible solutions for this partition so that the user may browse through them."
!ThingDebug class methodsFor: 'instance creation'!
on: aThing
"Create a new instance on the given Thing."
^(super new) on: aThing! !
Constraint subclass: #StayConstraint
instanceVariableNames: ''
classVariableNames: 'SharedMethods '
poolDictionaries: ''
category: 'ThingLabII-Constraints-Special'!
StayConstraint comment:
'I am used to mark variables should, with some level of preference, stay the same. I have only one method with no inputs and one output. My method does nothing. Planners may use the fact that, if I am satisfied, my output will not change to perform stay optimization.'!
!StayConstraint methodsFor: 'initialize-release'!
ref: ref strength: aSymbol
"Initialize myself with the given reference and strength."
strength _ Strength of: aSymbol.
symbols _ #(a).
self variables: (Array with: ref).
"initialize methods list shared by all instances"
(SharedMethods isNil) ifTrue:
[SharedMethods _ Array with:
((Method new)
codeString: '"stay"';
block: [: vars | "I do nothing" vars _ nil];
bindings: 'o')].
self methods: SharedMethods.
whichMethod _ nil.
self initializeFlags.! !
!StayConstraint methodsFor: 'queries'!
doesSomething
"Stay constraints have no effect other than to control the planning process."
!StayConstraint class methodsFor: 'instance creation'!
ref: ref strength: strength
"Create a new stay constraint on the referenced variable. For example:
StayConstraint
ref: aThing->#midpoint.y
strength: #default."
^(super new) ref: ref strength: strength! !
Object subclass: #Glyph
instanceVariableNames: 'location '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-UI-Framework'!
Glyph comment:
'This is an abstract class that defines the protocol used by components of a Scene to permit them to be laid out, displayed, and selected. Subclasses must implement the methods specified as ''subclassResponsibility'' (which are currently only displayOn:at:clippingBox: and boundingBox, but don''t trust this comment!!).'!
!Glyph methodsFor: 'initialize-release'!
initialize
"Initialize myself with default values. Subclasses should do 'super initialize' when overriding this method to ensure that instance variables owned by their superclass are properly initialized."
location _ 0@0.! !
!Glyph methodsFor: 'accessing'!
location
^location!
location: aPoint
location _ aPoint.! !
!Glyph methodsFor: 'glyph protocol'!
boundingBox
"Answer a Rectangle that completely surrounds all visible parts of me."
"Draw myself. The default is to do nothing. Visible glyphs supply a more specialized behavior for this method."!
glyphsComment
"This protocol describes the basic operations on graphical objects known as 'glyphs'. A glyph may be displayed, selected, and moved. The three categories of glyphs are:
1. visible glyphs -- glyphs that are visible in the display
2. selectable glyphs -- glyphs that can be selected and moved
3. input glyphs -- glyphs that respond to keyboard and/or mouse events
These categories are orthogonal, so it is possible to have visible glyphs that cannot be selected and moved or glyphs that can be selected but are not visible.
All glyphs must respond to basic glyph protocol:
boundingBox -- Essential!!
displayOn:at:clippingBox:
boundingBox
initialize
The only essential message is boundingBox; default behavior is provided for the other messages, although since the default displayOn:at:clippingBox: behavior is to do nothing, a glyph that does not override this default will be invisible.
For a glyph to be considered an input glyph, it must also answer true to one of:
wantsKeystrokes
wantsMouse
and it must support the corresponding keyboard and/or mouse prototcol."!
Terms of the first form are kept in an OrderedCollection of Arrays of the form:
(aStrength, aWalkEquation)
while terms of the second form are kept in a dictionary indexed by variable. The entries of this dictionary are WalkEquations. Terms of the third form are kept in an OrderedCollection.
My simplification rules are similar to those of OrEquations, except that:
1. ''true'' terms are removed instead of ''false'' terms
2. a ''false'' term makes the entire conjection ''false'' regardless of other terms
3. OrEquation terms are simplified
Instance variables (in addition to those inherited):
varEquations... maps ModuleVarTableEntries to WalkEquations
"This method is used in simplifying module boolean equations. Answer true if the given term should be kept. A term has the form:
aStrength notStronger: aWalkEquation
As a side effect, set the known value of myself (a boolean conjunction or disjunction) if possible. Assume that the sender has verified that the left side is a constant and that the right side has a constant part."
"Since I am a conjunction (AND), I can remove all true constant terms. A false constant term makes the entire conjunction false."
(left stronger: right constant)
ifTrue:
["term is false, keep it and set known value"
knownValue _ false.
^true]
ifFalse:
[(right vars isEmpty)
ifTrue:
["term is true, don't keep it"
^false]
ifFalse:
["term value is not known, keep it"
^true]].!
simplify
"Simplify this equation by removing constant terms. Set known value if possible. For further details, see the comment for this method in my superclass."
| equations |
super simplify.
"empty orEquations and add back only the non-constant or false ones"
equations _ orEquations.
orEquations _ orEquations species new.
equations do:
[: eqn |
(eqn isFalse) ifTrue:
[knownValue _ false. "any false term makes the conjunction false"
"Set my underlying Thing and update my caches accordingly."
thing _ aThing.
self updateCaches.!
thingDatas
"Warning: thingDatasCache is a cache of my underlying Thing's ThingDatas. Care must be used to ensure that this cache is kept up to date. If in doubt, send me the message updateGlyphsCache."
^thingDatas! !
!ThingAdaptor methodsFor: 'glyphs access'!
inputGlyphs
"Warning: inputGlyphs is a cache of my underlying Thing's input glyphs. Care must be used to ensure that this cache is kept up to date. If in doubt, send me the message updateGlyphsCache."
^inputGlyphs!
selectableGlyphs
"Warning: selectableGlyphs is a cache of my underlying Thing's selectable glyphs. Care must be used to ensure that this cache is kept up to date. If in doubt, send me the message updateGlyphsCache."
^selectableGlyphs!
visibleGlyphs
"Warning: glyphs is a cache of my underlying Thing's glyphs. Care must be used to ensure that this cache is kept up to date. If in doubt, send me the message updateGlyphsCache."
^glyphs! !
!ThingAdaptor methodsFor: 'glyphs'!
addGlyph: aThing
self shouldNotImplement.!
isChanging: aThingGlyph
"Answer true if the give glyph is undergoing changes that could effect how it is displayed."
!LayoutGlyph class methodsFor: 'instance creation'!
label: aNumber
"Answer a new instance of the receiver with the given label."
^(super new) label: aNumber! !
SceneController subclass: #PartsBinController
instanceVariableNames: 'currentCursor '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-UI-Parts Bin'!
PartsBinController comment:
'I am a controller for PartsBinIconViews. I support PartsBin operations such as move, delete, open bin, edit icon, change name, and many more. Some of these operations are available from my menu, others through direct manipulation (dragging, double-clicking, etc).'!
"Answer my yellow-button menu given the current selection and possibly some other view or controller state. The goal is to present in the menu only those possibilities which are legal commands at this juncture. If debugging is true, present a additional options which might be useful to implementors and other gurus."
| argCount arg |
argCount _ model selected size.
(argCount == 1)
ifTrue: [arg _ model selected asOrderedCollection first].
super addMenuItems: debugging.
myMenu add: ' new thing ' action: #createThing.
(model isAllParts not) ifTrue:
[myMenu add: ' new bin ' action: #createBin].
myMenu addLine.
(argCount == 1) ifTrue:
[myMenu add: ' rename ' action: #changeName.
myMenu add: ' edit icon ' action: #changeIcon].
(argCount > 0) ifTrue:
[myMenu add: ' delete ' action: #delete].
myMenu addLine.
myMenu add: ' arrange ' action: #arrange.
myMenu add: ' update ' action: #update.
myMenu addLine.
((argCount == 1) and: [arg holdsThing]) ifTrue:
[myMenu add: ' explain ' action: #explainThing.
myMenu add: ' inspect ' action: #inspectThing.
myMenu addLine].
(argCount == 1) ifTrue:
[myMenu add: ' open ' action: #open.
(debugging | arg holdsPartsBin) ifTrue:
[myMenu add: ' push ' action: #enterBin]].
(view canExit) ifTrue:
[myMenu add: ' pop ' action: #exitBin].!
arrange
BusyCursor begin.
model arrangeIn: (0@0 extent: view insetDisplayBox extent).
view computeEnclosingRectangle.
view scrollOffset: 0@0.
view displayScene.
BusyCursor end.!
changeIcon
"Edit the icon of the selected Thing or PartsBin."
"Deposit moving parts in the view containing aPoint if it is one of ours. Otherwise, complete a move operation within this view. When this method is invoked, the parts have already been dragged in this view, so if we are copying into another view, we must move the copies in this view back to their original positions."
| destTopView destView |
"Are we moving parts to another view?"
destTopView _ self destinationTopView.
(destTopView isNil)
ifTrue: "no, moving within this view"
[view shiftOrigin; displayView]
ifFalse: "yes, copying to another view"
["first, undo the part moving that we did in this view"
movingParts
with: originalPositions
do: [: p : originalPos | p location: originalPos].
"bring destination view forward and display it with the new parts"
destTopView displaySafe: [destView displayView].
copyFlag "if copyFlag is false, this is a move between bins"
ifFalse: [self delete]].!
doubleClickAt: aPoint
"Handle a double-click action by trying to open the object under aPoint. A double-click that is not over an icon does a selectAll."
((self glyphAt: aPoint) isNil)
ifTrue:
[self selectAll.
sensor waitNoButton]
ifFalse:
[model clearSelection.
self selectAt: aPoint toggleFlag: false.
view displayScene.
(sensor leftShiftDown)
ifTrue: [self enterBin]
ifFalse: [self open]].!
moveAt: aPoint
"Drag all selected parts for a move or copy operation. If the destination view is different than my view, then this is a copy operation. Otherwise, the parts are simply moved."
| movingParts relativePositions copyFlag oldPositions point oldPoint |
movingParts _ model selected asOrderedCollection.
model moveToFront: movingParts.
relativePositions _ movingParts collect: [: p | p location - aPoint].
copyFlag _ sensor leftShiftDown not.
oldPositions _ movingParts collect: [: p | p location].
view computeBackground.
[sensor redButtonPressed] whileTrue:
[point _ sensor cursorPoint.
(point ~= oldPoint) ifTrue:
[movingParts
with: relativePositions
do: [: p : relPos | p location: (relPos + point)].
self doCursorFeedback.
view displayFeedback]].
self
deposit: movingParts at: relativePositions
relativeTo: sensor cursorPoint
orginallyAt: oldPositions
copyFlag: copyFlag.
Cursor normal show.! !
!PartsBinController methodsFor: 'private'!
destinationAt: aPoint in: aView
"Answer a view that can accept icons under the given point in the given top view."
aView subViews do:
[: subView |
((subView containsPoint: aPoint) and:
[(subView isMemberOf: PartsBinView) |
(subView isMemberOf: ThingConstructorView) |
(subView isMemberOf: MultiThingView)])
ifTrue: [^subView]].
^nil!
destinationTopView
"Answer the top view of the destination for a move or copy between views. Answer nil if the destination is myself or if there is no appropriate destination under the cursor."
| point aTopView |
(self viewHasCursor) ifTrue: [^nil].
point _ sensor cursorPoint.
ScheduledControllers scheduledControllers do:
[: c | ((self destinationAt: point in: (c view)) notNil)
ifTrue: [^c view]].
^nil!
doCursorFeedback
"Show a bull's eye cursor if we are over a view that could be the destination for this move operation. Show the normal cursor otherwise."
(self destinationTopView isNil)
ifTrue: [(currentCursor ~~ Cursor normal)
ifTrue: [(currentCursor _ Cursor normal) show]]
ifFalse: [(currentCursor ~~ Cursor bull)
ifTrue: [(currentCursor _ Cursor bull) show]].! !
SceneController subclass: #BasicThingController
instanceVariableNames: 'editConstraints plan running '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-UI-Thing Views'!
BasicThingController comment:
'This is the controller class for BasicThingControllers.'!
"Answer my yellow-button menu given the current selection and possibly some other view or controller state. The goal is to present in the menu only those possibilities which are legal commands at this juncture. If debugging is true, present a additional options which might be useful to implementors and other gurus."
| argCount |
argCount _ model selected size.
"add superclass menu items"
super addMenuItems: debugging.
(running)
ifTrue:
[myMenu add: ' stop ' action: #stop]
ifFalse:
[myMenu add: ' step ' action: #step.
myMenu add: ' run ' action: #run].
myMenu addLine.
(argCount <= 1) ifTrue:
[myMenu add: ' explain ' action: #explain.
myMenu add: ' inspect ' action: #inspectThing].
myMenu add: ' debugger ' action: #openDebugger.
myMenu addLine.!
explain
"If a single part is selected, explain that part. Otherwise, explain the top-level Thing (the Thing under construction)."
(self argument notNil)
ifTrue: [Explanation openOn: self argument]
ifFalse: [Explanation openOn: model thing].!
inspectThing
"If a single part is selected, inspect that part. Otherwise, inspect the top-level Thing (the Thing under construction)."
(self argument notNil)
ifTrue: [self argument inspect]
ifFalse: [model thing inspect].!
openDebugger
"Open a ThingDebugView on my Thing."
ThingDebugView openOn: model thing.!
run
"Allow history to advance as fast as it can be computed."
"An input constraint could not be satisfied. Flash the view and abort."
view flash.
editConstraints do: [: c | c removeConstraint. c destroy].
editConstraints _ editConstraints species new.
running ifTrue: [self makePlan].!
addInputConstraints: constraintsList
"Add the given list of constraints and remember them in editConstraints."
constraintsList do:
[: c |
c addConstraint.
editConstraints add: c].!
addMouseConstraintsFor: movingParts with: offsets
"Add mouse constraints (which are special user input constraints) for the given collection of parts at the associated offsets from the mouse position."
| part offset |
editConstraints _ editConstraints species new.
1 to: movingParts size do: [: i |
part _ movingParts at: i.
offset _ offsets at: i.
editConstraints add:
(XMouseConstraint
ref: part->#x
strength: (ThingLabII editStrength)
offset: offset x).
editConstraints add:
(YMouseConstraint
ref: part->#y
strength: (ThingLabII editStrength)
offset: offset y)].
editConstraints do: [: c | c addConstraint].
self makePlan.!
cannotEditThing
"Answer true if any of the edit constraints is not satisfied."
editConstraints do: [: c |
(c isSatisfied) ifFalse: [^true]].
^false!
executeAndRedisplay
"Advance history if necessary, execute the plan, and display new state."
running ifTrue: [model advanceHistory].
plan execute.
view displayFeedback.!
makePlan
"Plan for constraint satisfaction and redisplay. This includes making a constraint satisfaction plan, computing the model's fixed glyphs, and computing the background form for redisplay."
| allThingDatas c |
allThingDatas _ model thingDatas copy.
editConstraints do:
[: c |
(c isSatisfied) ifTrue:
[c outDatasDo:
[: out | allThingDatas add: out]]].
plan _ DeltaBluePlanner
extractPlanFromChangingThingDatas: allThingDatas.
view computeBackground.!
removeInputConstraints
model advanceHistory.
editConstraints do: [: c | c removeConstraint. c destroy].
editConstraints _ editConstraints species new.
self makePlan.
self executeAndRedisplay.!
removeInputConstraints: constraintsList
"Remove the given list of constraints but do not replan."
constraintsList do:
[: c |
c removeConstraint.
editConstraints remove: c.
c destroy].!
removeMouseConstraints
"Just provides a more mnemonic name for this function when used with mouse constraints."
!ButtonGlyph class methodsFor: 'instance creation'!
at: aPoint form: aForm
^(self new) location: aPoint; form: aForm! !
SceneView subclass: #PartsBinView
instanceVariableNames: 'path '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-UI-Parts Bin'!
PartsBinView comment:
'I am a view used to display a two-dimensional layout of part icons. Each icon has a location and a name and is capable of displaying itself. PartsBin is my model and PartsBinIconController is my controller.'!
"Accept copies of the given collections of parts. Each part should be placed at the location given by the corresponding element of the relPoints collection, relative to the given point."
| parts refPoint |
(model isAllParts) ifTrue: [^self flash].
parts _ partsCollection collect: [: p | p copy].
refPoint _ aPoint - self insetDisplayBox origin.
parts with: relPoints do:
[: p : relLoc | model addPart: p at: (refPoint + relLoc)].
self shiftOrigin.!
canExit
^path isEmpty not!
enter: aPartsBin
path addLast: model.
self model: aPartsBin.
self newLabel: aPartsBin name.
self computeEnclosingRectangle.
self scrollOffset: 0@0.!
exit
(path isEmpty) ifTrue: [^self flash].
self model: path removeLast.
self newLabel: self model name.
self computeEnclosingRectangle.
self scrollOffset: 0@0.! !
!PartsBinView methodsFor: 'updating'!
doneEditingForm
"Sent by a NotifyingBitEditor when it is done editing a part icon. This event is not interesting to me."!
formChanged
"Sent by a NotifyingBitEditor when one of my part's icons has been
edited."
self displaySafe: [self displayScene].!
shiftOrigin
"Move all my glyphs so that they have positive locations."
'This is an abstract class for a special kind of Glyph that displays an icon with a centered text label below it. Subclasses must respond to these messages:
name
name:
icon
icon:
I cache a Form for my name in the instance variable ''nameForm'' for more efficient display. My subclasses must update this cache whenever their name changes by sending the message updateNameIcon to self.'!
!IconGlyph methodsFor: 'initialize-release'!
initialize
"Use a dummy Form until nameForm can be updated from the actual object name."
super initialize.
nameForm _ Form extent: (10@12).! !
!IconGlyph methodsFor: 'accessing'!
icon
^self subclassResponsibility!
icon: aForm
^self subclassResponsibility!
name
^self subclassResponsibility!
name: aString
"Note: after changing my name, send myself the message 'updateNameForm'."
^self subclassResponsibility!
updateNameForm
"For efficiency, I cache a Form containing the bitmap for the text of my name."
"Answer my yellow-button menu given the current selection and possibly some other view or controller state. The goal is to present in the menu only those possibilities which are legal commands at this juncture. If debugging is true, present a additional options which might be useful to implementors and other gurus."
"Move all selected parts. If only one part is being moved, try to merge it with the part (if any) at its new location."
| parts partLocations |
parts _ model selected asOrderedCollection.
(parts size == 1)
ifTrue: "do a merge"
[self
while: [sensor anyButtonPressed]
merge: parts first
refPoint: aPoint]
ifFalse: "do a group-move"
[partLocations _ parts collect: [: p | p location].
self
while: [sensor anyButtonPressed]
move: partLocations
refPoint: aPoint].
view computeEnclosingRectangle.
view displayView.!
while: testBlock merge: aThing refPoint: refPoint
"Move the given Thing. Give feedback on the possibility of merging with any Thing under the cursor. Do the merge if the mouse is released at such a moment."
"If part1 is a Node Thing, fix part2's value part before doing a merge. However, do not do this if part2's value is determined by a constraint. Finally, any value has precedence over a value of nil. Assume that part1 and part2 are Things of the same class."
"ignore non-Node Things"
(part1 isMemberOf: Node) ifFalse: [^self].
"exterminate nil's, if there are any"
(part1 value isNil) ifTrue:
[part1 primvalue: part2 value].
(part2 value isNil) ifTrue:
[part2 primvalue: part1 value].
"copy the value from part1 to the value slot of part2 unless part2 has constraints"
part1 primvalue: part2 value.
(part2 thingDataForYourself isNil) ifTrue:
[part2 primvalue: part1 value].!
mergeParts: partsList
"Merge the given parts. I assume that the sender has already determined that the parts can be merged. Answer true if my name had to be changed to perform the merge."
| cluster nameChanged |
cluster _ partsList first.
nameChanged _ false.
(partsList copyFrom: 2 to: partsList size) do:
[: p |
self copyValueFrom: cluster to: p.
(model thing mergePart: p withPart: cluster) ifTrue:
[nameChanged _ true]].
" refresh the glyphs cache and reselect the merged part"
model updateCaches.
partsList do:
[: p | (p parents notNil) ifTrue: [model select: p]].
^nameChanged!
tryToMerge: p1
"Attempt to merge the given part with the part 'under' it. This is done at the end of a move operation if only one part was being moved and allows the user to perform a merge by simply stacking two mergeable parts."
| p1Location p2 |
p1Location _ p1 location asPoint.
p2 _ (model selectableGlyphs)
detect: [: g |
((g ~~ p1) & (g containsPoint: p1Location)) and:
[self canMergeParts: (Array
with: p1
with: g)]]
ifNone: [^self].
(self mergeParts: (Array with: p1 with: p2))
ifTrue: [view newLabel: model name].
model updateCaches.
view displayView.!
unmergeCluster: aPart
"Completely unmerge the given part (i.e. if three points were merged to create the part, it will be replaced by three new points. Collect references for all the selectable newly liberated parts into the given set. Answer true if my Thing changed its name."
| root paths delta nameChanged |
root _ aPart value topParent.
paths _ (aPart value allTopParentPaths)
collect: [: path | Reference on: root path: path].
(paths size < 2)
ifTrue: [^false]. "nothing to unmerge"
delta _ 5.
nameChanged _ false.
(paths copyFrom: 1 to: paths size - 1) do:
[: ref |
(model thing extractMergedPart: ref) ifTrue:
[nameChanged _ true].
"hack to offset locations to make unmerge visible"
(ref value selectableGlyphs) do:
[: g | (g location) set: #x to: (g location asPoint x + delta)].
delta _ delta + 5].
"make anchor nodes revert to nil value"
paths do:
[: ref |
(ref finalVariable isMemberOf: NodeAnchor)
ifTrue: [(ref, #(value)) value: nil]].
model updateCaches.
paths do:
[: ref |
(ref value selectableGlyphs) do:
[: glyph | model select: glyph]].
^nameChanged!
unmergeParts: partsList
"Unmerge the parts with the given references and answer true if my name had to be changed to perform the operation. I assume the sender has verified that the model's structure can be modified."
'I contain a collection of Things and PartsBins, which are stored in PartsHolder objects in my glyphs collection. Like Things, I have a name and and icon, allowing me to be contained in other PartBins. If references to me appear in several parts bins, they will all display with the same name, icon, and parts selection. Some of my instances may be ''AllParts'' bins. An ''AllParts'' bin contains every currently existing Thing prototype.'!
!PartsBin methodsFor: 'initialize-release'!
initialize: nameString isAllParts: isAllParts
super initialize.
name _ nameString.
icon _ DefaultIcon deepCopy.
allPartsFlag _ isAllParts.
allPartsFlag
ifTrue: [self syncWithReality: nil].! !
!PartsBin methodsFor: 'accessing'!
allPartsFlag: aBoolean
allPartsFlag _ aBoolean.!
icon
^icon!
icon: aForm
icon _ aForm.!
isAllParts
^allPartsFlag!
name
^name!
name: aString
name _ aString.! !
!PartsBin methodsFor: 'operations'!
addPart: aPartHolder
"Note: You can't anything to All Parts."
(self isAllParts) ifTrue: [^self]. "can't add to AllParts"
self findLocationFor: aPartHolder.
self addGlyph: aPartHolder.!
addPart: aPartHolder at: aLocation
"Note: You can't add Things or bins to All Parts."
"tempoarily remove all parts so we can consider overlaps only with parts that have already been positioned; parts will be re-instated as they are positioned."
glyphs _ glyphs species new: glyphs size.
"move mis-aligned or overlapping parts within the view box"
insideGlyphs do:
[: g |
BusyCursor inc.
((self aligned: g) not or: [self isOverlapping: g])
ifTrue: [self findLocationFor: g inside: box].
glyphs addLast: g].
"try to move parts into the view box"
outsideGlyphs do:
[: g |
BusyCursor inc.
g location: box origin. "start at the top left"
self findLocationFor: g inside: box.
glyphs addLast: g].!
findLocationFor: aPartHolder
"Use when there may not be an open view for this PartsBin. Finds a location for aPartHolder assuming typical view dimensions. The location of aPartHolder is modified."
self
findLocationFor: aPartHolder
inside: (0@0 corner: 200@120).!
findLocationFor: aPartHolder inside: box
"Find a location in this bin for the given PartHolder and move it to that location. Try to stay inside the given bounding box."
| possibleX possibleY rightEdge |
possibleX _ (aPartHolder location x asFloat roundTo: GridX) max: GridX.
possibleY _ (aPartHolder location y asFloat roundTo: GridY) max: GridY.
"Answer true if aPartHolder is overlaps some other PartHolder in this bin."
"Note: Because computing the intersection of bounding boxes proved very expensive, this algorithm simply checks to see if aPartHolder is within a small Euclidian distance of any other PartHolder in this parts bin."
| vec |
glyphs do:
[: g |
vec _ g location - aPartHolder location.
((g ~~ aPartHolder) and:
[(vec x abs + vec y abs) < 10])
ifTrue: [^true]].
^false!
part: aPartHolder inside: aRectangle
"Answer true if aPartHolder is completely inside the given rectangle."
^aRectangle contains: aPartHolder boundingBox! !
!PartsBin methodsFor: 'updating'!
syncWithReality: viewBox
"Update myself from the underlying Thing database. If viewBox is not nil, then it is the window of the view on me that initiated this operation."
| realThings oldThings pHolder changed |
changed _ false.
BusyCursor begin.
"Construct a list of all Things that currently exist."
"Answer a parts bin that contains all currently existing Things."
^(super new)
initialize: 'All Parts'
isAllParts: true!
newNamed: aString
"Answer a new, empty bin with the given name."
^(super new)
initialize: aString
isAllParts: false! !
!PartsBin class methodsFor: 'top bin access'!
newTopBin
"Ask for confirmation, then create the root of the bin tree from scratch. Note that this will throw away all user-created bins!! All Things will still be accessible via the All Parts bin, of course."
"PartsBin newTopBin."
(self confirm:
'Making a new Top Bin will remove all
user bins. Do you wish to continue?')
ifFalse: [^nil].
TopBin _ self newNamed: 'Top Bin'.
TopBin
addPart: (PartHolder on: (PartsBin newAllParts))
at: GridX@GridY.!
topBin
"Answer the root of the bin tree."
^TopBin!
updateAllBins
"Update all PartsBins accessible from the top bin. Used after updating all the PrimitiveThings prototypes."
"PartsBin updateAllBins"
| toDo partsBin |
toDo _ OrderedCollection with: TopBin.
[toDo isEmpty] whileFalse:
[partsBin _ toDo removeFirst.
toDo addAll: partsBin partsBinsSet.
partsBin syncWithReality: nil].! !
!PartsBin class methodsFor: 'grid parameters'!
gridX
^GridX!
gridX: aNumber
GridX _ aNumber.!
gridY
^GridY!
gridY: aNumber
GridY _ aNumber.! !
!PartsBin class methodsFor: 'class initialization'!
initialize
"Initialize the default PartsBin icon and the grid for parts placement."
"Set my underlying Thing and update my caches accordingly."
self shouldNotImplement!
thingDatas
"Warning: thingDatasCache is a cache of my underlying Thing's ThingDatas. Care must be used to ensure that this cache is kept up to date. If in doubt, send me the message updateGlyphsCache."
^thingDatas! !
!MultiThingAdaptor methodsFor: 'glyphs access'!
inputGlyphs
"Warning: inputGlyphs is a cache of my underlying Thing's input glyphs. Care must be used to ensure that this cache is kept up to date. If in doubt, send me the message updateGlyphsCache."
^inputGlyphs!
selectableGlyphs
"Warning: selectableGlyphs is a cache of my underlying Thing's selectable glyphs. Care must be used to ensure that this cache is kept up to date. If in doubt, send me the message updateGlyphsCache."
^selectableGlyphs!
visibleGlyphs
"Warning: glyphs is a cache of my underlying Thing's glyphs. Care must be used to ensure that this cache is kept up to date. If in doubt, send me the message updateGlyphsCache."
^visibleGlyphs! !
!MultiThingAdaptor methodsFor: 'glyphs'!
addGlyph: aThing
super addGlyph: aThing.
self updateCaches.!
isChanging: aThingGlyph
"Answer true if the give glyph is undergoing changes that could effect how it is displayed."
aThingGlyph glyphDependsOn do:
[: aThing |
(self thingIsChanging: aThing) ifTrue:
[^true]]. "must redisplay this glyph every time"
"the glyph does not depend on any changing parts"
^false!
removeGlyph: aThing
super removeGlyph: aThing.
self updateCaches.!
thingIsChanging: aThing
"Answer true if the given Thing has a constrained part whose stay flag is not true."
"if the thing has no thingDatas, then it is fixed"
(aThing thingDatas isEmpty) ifTrue: [^false].
aThing thingDatas do:
[: thingData |
(thingData stay not) ifTrue: [^true]]. "thing is not fixed"
"If a single part is selected, explain that part. Otherwise, explain the top-level Thing (the Thing under construction)."
(self argument notNil)
ifTrue: [Explanation openOn: self argument]
ifFalse: [view flash].!
inspectThing
"If a single part is selected, inspect that part. Otherwise, inspect the top-level Thing (the Thing under construction)."
(self argument notNil)
ifTrue: [self argument inspect]
ifFalse: [ view flash].!
openDebugger
"Open a ThingDebugView on my Thing."
view flash.! !
IconGlyph subclass: #PartHolder
instanceVariableNames: 'cargo lastFrame '
classVariableNames: ''
poolDictionaries: ''
category: 'ThingLabII-UI-Parts Bin'!
PartHolder comment:
'I am a holder for parts and parts bins. I inherit a location variable from Glyph and protocol for displaying myself from IconGlyph. I have a contents variable to store the Thing or PartsBin that I contain. My name and icon are those of my contents; I can only store objects that have names and icons.'!
!PartHolder methodsFor: 'initialize-release'!
initialize
super initialize.
cargo _ nil.
lastFrame _ nil.! !
!PartHolder methodsFor: 'accessing'!
cargo
^cargo!
cargo: anObject
cargo _ anObject.
self updateNameForm.!
icon
^cargo icon!
icon: aForm
cargo icon: aForm.!
lastFrame
"Answer the view frame when this part was last closed."
^lastFrame!
lastFrame: aRectangle
"Set the view frame when this part was last closed."
lastFrame _ aRectangle.!
name
^cargo name!
name: aString
cargo name: aString.
self updateNameForm.! !
!PartHolder methodsFor: 'testing'!
holdsAllParts
"Answer true if my cargo is an 'All Parts' PartsBin."
"Answer my yellow-button menu given the current selection and possibly some other view or controller state. The goal is to present in the menu only those possibilities which are legal commands at this juncture. If debugging is true, present a additional options which might be useful to implementors and other gurus."
super addMenuItems: debugging.
myMenu add: ' layout ' action: #layout.
myMenu add: ' center constraints ' action: #centerConstraints.
"Find a FrameThing in my model and ensure that its topLeft corner is 0@0 and its bottomRight corner is the current extent. If there is no FrameThing or if it doesn't need to be updated, do nothing."
"Answer my yellow-button menu given the current selection and possibly some other view or controller state. The goal is to present in the menu only those possibilities which are legal commands at this juncture. If debugging is true, present a additional options which might be useful to implementors and other gurus."
